CorelDRAW X4 VBA自动闭合曲线 分享
此程序用于自动闭合曲线，相邻两点自动连接，应用此程序时，需要注意以下两点：
①将所要自动闭合的曲线“组合”（Ctrl+L)，不是群组（Ctrl+G)；
②组合的曲线中没有杂点、单线，如从CAD或AI中导过来的图形，需仔细检查。
③如上面两点没处理好，将导致程序处理缓慢，甚至假死。
④如有高人能将此程序加上几句以处理以上问题，再好不过了。
Sub CloseShape() '自动闭合曲线
Dim s As Shape
Dim e As Double, r As Double, nr As Double
Dim sp As SubPath
Dim sn As Node, en As Node, n1 As Node, n2 As Node
Dim b As Boolean
Set s = ActiveShape
If s.Type <> cdrCurveShape Then
MsgBox "Curve must be selected"
Exit Sub
End If
' E is auto-join limit beyond which the nodes are joined rather than connected
' Here assumed to be 1% of an average object size
e = s.SizeHeight * s.SizeWidth / 10000
Do
Set sn = Nothing
Set en = Nothing
Set n1 = Nothing
Set n2 = Nothing
b = False
For Each sp In s.Curve.SubPaths
If Not sp.Closed Then
Set n1 = sp.StartNode
Set n2 = sp.EndNode
nr = n1.GetDistanceFrom(n2)
If nr < e And sp.Nodes.Count > 2 Then
n1.JoinWith n2
b = True
Else
If sn Is Nothing Then
Set sn = n1
Set en = n2
r = nr
Else
nr = sn.GetDistanceFrom(n1)
If nr < r Then
Set en = n1
r = nr
End If
nr = sn.GetDistanceFrom(n2)
If nr < r Then
Set en = n2
r = nr
End If
End If
End If
End If
If b Then Exit For
Next sp
If Not b And Not sn Is Nothing Then
If r < e Then sn.JoinWith en Else sn.ConnectWith en
b = True
End If
Loop While b
End Sub
①将所要自动闭合的曲线“组合”（Ctrl+L)，不是群组（Ctrl+G)；
②组合的曲线中没有杂点、单线，如从CAD或AI中导过来的图形，需仔细检查。
③如上面两点没处理好，将导致程序处理缓慢，甚至假死。
④如有高人能将此程序加上几句以处理以上问题，再好不过了。
Sub CloseShape() '自动闭合曲线
Dim s As Shape
Dim e As Double, r As Double, nr As Double
Dim sp As SubPath
Dim sn As Node, en As Node, n1 As Node, n2 As Node
Dim b As Boolean
Set s = ActiveShape
If s.Type <> cdrCurveShape Then
MsgBox "Curve must be selected"
Exit Sub
End If
' E is auto-join limit beyond which the nodes are joined rather than connected
' Here assumed to be 1% of an average object size
e = s.SizeHeight * s.SizeWidth / 10000
Do
Set sn = Nothing
Set en = Nothing
Set n1 = Nothing
Set n2 = Nothing
b = False
For Each sp In s.Curve.SubPaths
If Not sp.Closed Then
Set n1 = sp.StartNode
Set n2 = sp.EndNode
nr = n1.GetDistanceFrom(n2)
If nr < e And sp.Nodes.Count > 2 Then
n1.JoinWith n2
b = True
Else
If sn Is Nothing Then
Set sn = n1
Set en = n2
r = nr
Else
nr = sn.GetDistanceFrom(n1)
If nr < r Then
Set en = n1
r = nr
End If
nr = sn.GetDistanceFrom(n2)
If nr < r Then
Set en = n2
r = nr
End If
End If
End If
End If
If b Then Exit For
Next sp
If Not b And Not sn Is Nothing Then
If r < e Then sn.JoinWith en Else sn.ConnectWith en
b = True
End If
Loop While b
End Sub
