异形内水平画小圆

作了一些修正：
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 CireclD As Double
Dim inSxD As Double '起点偏移值变量inSxD
Dim DotCount As Integer '点数
Dim i As Integer '循环计数变量i
Dim i1 As Integer '循环计数变量i1
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
DotCount = Int((myLine.Curve.length / CireclD))
inSxD = (myLine.Curve.length - DotCount * CireclD) / 2
DotCount = DotCount + 1
For i = 1 To DotCount Step 1
Set hY = ActiveLayer.CreateEllipse2(CircleX + inSxD + (i - 1) * CireclD, CireclY, inR)
hY.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If IsCircleValid(hY, inShape) = True Then hY.Delete
Next i
End If
If myLine.Curve.SubPaths.Count > 1 Then
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
DotCount = Int((s1SPi.length / CireclD))
inSxD = (s1SPi.length - DotCount * CireclD) / 2
DotCount = DotCount + 1
For i1 = 1 To DotCount Step 1
Set hY = ActiveLayer.CreateEllipse2(CircleX + inSxD + (i1 - 1) * CireclD, CireclY, inR)
hY.Outline.Color = CreateCMYKColor(0, 100, 100, 0)
If IsCircleValid(hY, inShape) = True Then hY.Delete
Next i1
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对象画网点
Dim eff1 As Effect
Dim myRed As Color
Dim rSdanWei As Double
Dim effSR As ShapeRange
rSdanWei = 20
Set myRed = CreateCMYKColor(0, 100, 100, 0)
Set eff1 = s1.CreateContour(cdrContourInside, rSdanWei, 1, cdrDirectFountainFillBlend, myRed, myRed, myRed, 0, 0, cdrContourSquareCap, cdrContourCornerMiteredOffsetBevel, 15#)
Set effSR = eff1.Separate
Dim s2 As Shape
Set s2 = effSR(1)
Call wLine0d(s2, 35, 4.5, 30)
s2.Delete
Unload UserForm1
Exit Sub
doc.EndCommandGroup
End Sub

做出了居中修正，保留了内缩线、参考横条网线，加入了On Error GoTo ErrHandler语句

Private Function xDrawLine(ByVal xStart As Double, ByVal yStart As Double, ByVal length As Double) As Shape
'函数参数：xStart起点X坐标，yStart起点Y坐标，length长度
Dim xEnd As Double
Dim yEnd As Double
xEnd = xStart + length
yEnd = yStart
' 绘制线
Dim lineShape As Shape
Set lineShape = ActiveLayer.CreateLineSegment(xStart, yStart, xEnd, yEnd)
' 返回线段对象
Set xDrawLine = lineShape
End Function
Private Function MyXJLine(ByVal InS1 As Shape, ByVal 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 wLine0d(ByVal inShape As Shape, ByVal inDs As Integer) As ShapeRange
'画0度水平线网
Dim mySelS As Shape
Dim myLine As Shape
Dim mySR As New ShapeRange
Dim myXs As Double
Dim myYs As Double
Dim myLength As Double
Dim myDistance As Double
Dim myCount As Long
Dim myRemainder As Double
Set mySelS = inShape
myXs = mySelS.LeftX
myYs = mySelS.TopY
myLength = inShape.SizeWidth
myDistance = inDs
myCount = Int(mySelS.SizeHeight / inDs)
myRemainder = mySelS.SizeHeight Mod myDistance
If myRemainder <> 0 Then myYs = myYs - (mySelS.SizeHeight - (myCount + 1) * myDistance) / 2
For i = 1 To myCount
myYs = myYs - myDistance
Set myLine = xDrawLine(myXs, myYs, myLength)
Set myLine = MyXJLine(mySelS, myLine)
If Not myLine Is Nothing Then mySR.Add myLine
Next i
Set wLine0d = mySR
End Function
Private Function DrawY(ByVal inShapeRange As ShapeRange, ByVal inRadius As Double, ByVal inRadiusDistance As Double) As ShapeRange
Dim YSR As New ShapeRange
Dim YS As Shape
Dim YR As Double
Dim YRD As Double
YR = inRadius
YRD = inRadiusDistance
For Each YS In inShapeRange
Dim Ydot As Shape
Dim YstartX As Double
Dim YstartY As Double
Dim DrawYlength As Double
Dim DrawYcount As Long
Dim SubI As Long
Dim Xhi As Long
If YS.Curve.SubPaths.Count = 1 Then '当画圆直线上子路径为1时
YstartX = YS.LeftX
YstartY = YS.CenterY
DrawYlength = YS.Curve.length
DrawYcount = Int(DrawYlength / YRD)
YstartX = YstartX + (YS.Curve.length - DrawYcount * YRD) / 2
For Xhi = 1 To DrawYcount + 1 Step 1
Set Ydot = ActiveLayer.CreateEllipse2(YstartX, YstartY, YR)
YstartX = YstartX + YRD
YSR.Add Ydot
Next Xhi
End If
If YS.Curve.SubPaths.Count > 1 Then '当画圆直线上子路径多于1时
For SubI = 1 To YS.Curve.SubPaths.Count
Dim s1SPi As SubPath
Set s1SPi = YS.Curve.SubPaths(SubI)
YstartX = s1SPi.StartNode.PositionX
YstartY = s1SPi.StartNode.PositionY
DrawYcount = Int(s1SPi.length / YRD)
'Debug.Print (s1SPi.length - DrawYcount * YRD) / 2
YstartX = YstartX + (s1SPi.length - DrawYcount * YRD) / 2
For Xhi = 1 To DrawYcount + 1 Step 1
Set Ydot = ActiveLayer.CreateEllipse2(YstartX, YstartY, YR)
YstartX = YstartX + YRD
YSR.Add Ydot
Next Xhi
Next SubI
End If
Next YS
Set DrawY = YSR
End Function
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 "内缩画线画点"
'放入撤消处理命令
On Error GoTo ErrHandler
Dim eff1 As Effect
Dim myRed As Color
Dim rSdanWei As Double
Dim effSR As ShapeRange
rSdanWei = 20 '内缩rSdanWei毫米
Set myRed = CreateCMYKColor(0, 100, 100, 0)
Set eff1 = s1.CreateContour(cdrContourInside, rSdanWei, 1, cdrDirectFountainFillBlend, myRed, myRed, myRed, 0, 0, cdrContourSquareCap, cdrContourCornerMiteredOffsetBevel, 15#)
Set effSR = eff1.Separate
Dim s2 As Shape
Set s2 = effSR(1)
Dim Lsr As ShapeRange
Dim Lheight As Double
Lheight = 30
Set Lsr = wLine0d(s2, Lheight)
Lsr.SetOutlineProperties Color:=myRed
Dim YdotSR As ShapeRange
Dim YdotRadius As Double
Dim YdotDistance As Double
YdotRadius = 4.5
YdotDistance = 30
Set YdotSR = DrawY(Lsr, YdotRadius, YdotDistance)
YdotSR.SetOutlineProperties Color:=myRed
Lsr.Group
YdotSR.Group
's2.Delete
'如果不要内轮廓线可以执行上面的注释代码
'lsr.Delete
'如果不要参考直线可以执行上面的注释代码
Unload UserForm1
Exit Sub
doc.EndCommandGroup
ErrHandler:
MsgBox "发生了错误: " & Err.Description
End Sub