Private Function xDrawLine(xStart As Double, yStart As Double, angle As Double, length As Double) As Shape
'函数参数:xStart起点X坐标,yStart起点Y坐标,angle角度,length长度
Dim xEnd As Double
Dim yEnd As Double
xEnd = xStart + length * Cos(DegToRad(angle))
yEnd = yStart + length * Sin(DegToRad(angle))
' 绘制线
Dim doc As CorelDRAW.Document
Set doc = CorelDRAW.ActiveDocument
Dim lineShape As CorelDRAW.Shape
Set lineShape = doc.ActiveLayer.CreateLineSegment(xStart, yStart, xEnd, yEnd)
' 返回线段对象
Set xDrawLine = lineShape
End Function
Private Function DegToRad(ByVal Degrees As Double) As Double
' 将角度转换为弧度
Dim Pi As Double
Pi = 3.1415
DegToRad = Degrees * Pi / 180
End Function
Private Function DiagonalLength(Width As Double, Height As Double) As Double
'--- 预留 ---利用勾股定理计算矩形对角线长度函数
Dim Diagonal As Double
Diagonal = Sqr(Width ^ 2 + Height ^ 2)
DiagonalLength = Diagonal
End Function
Private Function MyXJLine(InS1 As Shape, InS2 As Shape) As Shape
'返回相交Intersect线对象
Dim s1 As Shape
Set s1 = InS1.Intersect(InS2, True, True)
InS2.Delete
Set MyXJLine = s1
End Function
Private Function IsCircleValid(s2 As Shape, s1 As Shape) As Boolean
'判断是s2是否在s1外。如果在,则返回True。
If s1.IsOnShape(s2.LeftX, s2.BottomY) = cdrOutsideShape Then IsCircleValid = True
If s1.IsOnShape(s2.LeftX, s2.TopY) = cdrOutsideShape Then IsCircleValid = True
If s1.IsOnShape(s2.RightX, s2.TopY) = cdrOutsideShape Then IsCircleValid = True
If s1.IsOnShape(s2.RightX, s2.BottomY) = cdrOutsideShape Then IsCircleValid = True
If s2.DisplayCurve.IntersectsWith(s1.DisplayCurve) Then IsCircleValid = True
End Function
Private Sub wLine0d(inShape As Shape, inDs As Double, inR As Double, inRadiusDistance As Double)
'画0度水平线网加圆点
Dim mySelS As Shape
Dim myLine As Shape
Dim myXs As Double
Dim myYs As Double
Dim myAngle As Double
Dim myLength As Double
Dim myDistance As Double
Dim hY As Shape
Dim CircleX As Double
Dim CireclY As Double
Dim CireclEndX As Double
Dim CireclD As Double
Set mySelS = inShape
myXs = mySelS.LeftX
myYs = mySelS.TopY
myAngle = 0
myLength = inShape.SizeWidth
myDistance = inDs
CireclD = inRadiusDistance
Dim countI As Double
countI = 0
While countI <= mySelS.SizeHeight
myYs = myYs - myDistance
Set myLine = xDrawLine(myXs, myYs, myAngle, myLength)
Set myLine = MyXJLine(mySelS, myLine)
If Not myLine Is Nothing Then
'myLine.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If myLine.Curve.SubPaths.Count = 1 Then
CircleX = myLine.LeftX
CireclY = myLine.CenterY
CireclEndX = myLine.RightX - inR
For CircleX = myLine.LeftX To CireclEndX Step CireclD
Set hY = ActiveLayer.CreateEllipse2(CircleX, CireclY, inR)
hY.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If IsCircleValid(hY, inShape) = True Then hY.Delete
Next CircleX
End If
If myLine.Curve.SubPaths.Count > 1 Then
Dim i As Integer
For i = 1 To myLine.Curve.SubPaths.Count Step 1
Dim s1SPi As SubPath
Set s1SPi = myLine.Curve.SubPaths(i)
CircleX = s1SPi.StartNode.PositionX
CireclY = s1SPi.StartNode.PositionY
CircleXEndX = s1SPi.EndNode.PositionX - inR
For CircleX = CircleX To CircleXEndX Step CireclD
Set hY = ActiveLayer.CreateEllipse2(CircleX, CireclY, inR)
hY.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If IsCircleValid(hY, inShape) = True Then hY.Delete
Next CircleX
Next i
End If
End If
If Not myLine Is Nothing Then myLine.Delete
countI = countI + inDs
Wend
inShape.Selected = True
End Sub
Private Sub CommandButton1_Click()
'异形内画圆
Dim doc As Document
Set doc = CorelDRAW.ActiveDocument
doc.Unit = cdrMillimeter
If ActiveShape Is Nothing Then MsgBox "请选择图形": Exit Sub
Dim s1 As Shape
Set s1 = ActiveShape
If s1.Type <> cdrCurveShape Then
MsgBox "选择不是曲线物体,无法执行"
Exit Sub
End If
doc.BeginCommandGroup "画线"
'选择Shape对象画10段0度网线
Call wLine0d(CorelDRAW.ActiveShape, 35, 4.5, 30)
Unload UserForm1
Exit Sub
doc.EndCommandGroup
End Sub
'函数参数:xStart起点X坐标,yStart起点Y坐标,angle角度,length长度
Dim xEnd As Double
Dim yEnd As Double
xEnd = xStart + length * Cos(DegToRad(angle))
yEnd = yStart + length * Sin(DegToRad(angle))
' 绘制线
Dim doc As CorelDRAW.Document
Set doc = CorelDRAW.ActiveDocument
Dim lineShape As CorelDRAW.Shape
Set lineShape = doc.ActiveLayer.CreateLineSegment(xStart, yStart, xEnd, yEnd)
' 返回线段对象
Set xDrawLine = lineShape
End Function
Private Function DegToRad(ByVal Degrees As Double) As Double
' 将角度转换为弧度
Dim Pi As Double
Pi = 3.1415
DegToRad = Degrees * Pi / 180
End Function
Private Function DiagonalLength(Width As Double, Height As Double) As Double
'--- 预留 ---利用勾股定理计算矩形对角线长度函数
Dim Diagonal As Double
Diagonal = Sqr(Width ^ 2 + Height ^ 2)
DiagonalLength = Diagonal
End Function
Private Function MyXJLine(InS1 As Shape, InS2 As Shape) As Shape
'返回相交Intersect线对象
Dim s1 As Shape
Set s1 = InS1.Intersect(InS2, True, True)
InS2.Delete
Set MyXJLine = s1
End Function
Private Function IsCircleValid(s2 As Shape, s1 As Shape) As Boolean
'判断是s2是否在s1外。如果在,则返回True。
If s1.IsOnShape(s2.LeftX, s2.BottomY) = cdrOutsideShape Then IsCircleValid = True
If s1.IsOnShape(s2.LeftX, s2.TopY) = cdrOutsideShape Then IsCircleValid = True
If s1.IsOnShape(s2.RightX, s2.TopY) = cdrOutsideShape Then IsCircleValid = True
If s1.IsOnShape(s2.RightX, s2.BottomY) = cdrOutsideShape Then IsCircleValid = True
If s2.DisplayCurve.IntersectsWith(s1.DisplayCurve) Then IsCircleValid = True
End Function
Private Sub wLine0d(inShape As Shape, inDs As Double, inR As Double, inRadiusDistance As Double)
'画0度水平线网加圆点
Dim mySelS As Shape
Dim myLine As Shape
Dim myXs As Double
Dim myYs As Double
Dim myAngle As Double
Dim myLength As Double
Dim myDistance As Double
Dim hY As Shape
Dim CircleX As Double
Dim CireclY As Double
Dim CireclEndX As Double
Dim CireclD As Double
Set mySelS = inShape
myXs = mySelS.LeftX
myYs = mySelS.TopY
myAngle = 0
myLength = inShape.SizeWidth
myDistance = inDs
CireclD = inRadiusDistance
Dim countI As Double
countI = 0
While countI <= mySelS.SizeHeight
myYs = myYs - myDistance
Set myLine = xDrawLine(myXs, myYs, myAngle, myLength)
Set myLine = MyXJLine(mySelS, myLine)
If Not myLine Is Nothing Then
'myLine.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If myLine.Curve.SubPaths.Count = 1 Then
CircleX = myLine.LeftX
CireclY = myLine.CenterY
CireclEndX = myLine.RightX - inR
For CircleX = myLine.LeftX To CireclEndX Step CireclD
Set hY = ActiveLayer.CreateEllipse2(CircleX, CireclY, inR)
hY.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If IsCircleValid(hY, inShape) = True Then hY.Delete
Next CircleX
End If
If myLine.Curve.SubPaths.Count > 1 Then
Dim i As Integer
For i = 1 To myLine.Curve.SubPaths.Count Step 1
Dim s1SPi As SubPath
Set s1SPi = myLine.Curve.SubPaths(i)
CircleX = s1SPi.StartNode.PositionX
CireclY = s1SPi.StartNode.PositionY
CircleXEndX = s1SPi.EndNode.PositionX - inR
For CircleX = CircleX To CircleXEndX Step CireclD
Set hY = ActiveLayer.CreateEllipse2(CircleX, CireclY, inR)
hY.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If IsCircleValid(hY, inShape) = True Then hY.Delete
Next CircleX
Next i
End If
End If
If Not myLine Is Nothing Then myLine.Delete
countI = countI + inDs
Wend
inShape.Selected = True
End Sub
Private Sub CommandButton1_Click()
'异形内画圆
Dim doc As Document
Set doc = CorelDRAW.ActiveDocument
doc.Unit = cdrMillimeter
If ActiveShape Is Nothing Then MsgBox "请选择图形": Exit Sub
Dim s1 As Shape
Set s1 = ActiveShape
If s1.Type <> cdrCurveShape Then
MsgBox "选择不是曲线物体,无法执行"
Exit Sub
End If
doc.BeginCommandGroup "画线"
'选择Shape对象画10段0度网线
Call wLine0d(CorelDRAW.ActiveShape, 35, 4.5, 30)
Unload UserForm1
Exit Sub
doc.EndCommandGroup
End Sub