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