增加隐藏功能 Ctrl ALt shift 触发

ALGO.bas

@@ -1,104 +1,104 @@
-Attribute VB_Name = "ALGO"
-'// This is free and unencumbered software released into the public domain.
-'// For more information, please refer to  https://github.com/hongwenjun
-
-'// Algorithm 模块
-#If VBA7 Then
-'// For CorelDRAW X6-2023  62bit
-'// Private Declare PtrSafe Function sort_byitem Lib "C:\TSP\lyvba.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
-'//                       ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
-#Else
-'// For CorelDRAW X4  32bit
-Declare Function sort_byitem Lib "C:\TSP\lyvba32.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
-                      ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
-#End If
-
-Type ShapeProperties
-  Item As Long                 '// ShapeRange.Item
-  StaticID As Long             '// Shape.StaticID
-  lx As Double: rx As Double   '// s.LeftX  s.RightX  s.BottomY  s.TopY
-  by As Double: ty As Double
-  cx As Double: cy As Double   '// s.CenterX  s.CenterY s.SizeWidth s.SizeHeight
-  sw As Double: sh As Double
-End Type
-
-Enum SortItem
-  stlx
-  strx
-  stby
-  stty
-  stcx
-  stcy
-  stsw
-  stsh
-  Area
-  topWt_left
-End Enum
-
-Private Sub Test_Sort_ShapeRange()
-  API.BeginOpt
-  Dim sr As ShapeRange, ssr As ShapeRange
-  Dim s As Shape
-  Set sr = ActiveSelectionRange
-  Set ssr = ShapeRange_To_Sort_Array(sr, topWt_left)
-
-  '// s 调整次序
-  For Each s In ssr
-    s.OrderToFront
-  Next s
-
-  MsgBox "ShapeRange_SortItem:" & " " & topWt_left & "  枚举值"
-  API.EndOpt
-End Sub
-
-
-Public Function X4_Sort_ShapeRange(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
-  Set X4_Sort_ShapeRange = ShapeRange_To_Sort_Array(sr, Sort_By)
-End Function
-
-'// 映射 ShapeRange 到 Array 然后调用 DLL库排序
-Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
-'  On Error GoTo ErrorHandler
-  Dim sp As ShapeProperties
-  Dim size As Long, ret As Long
-  Dim s As Shape
-  size = sr.Count
-  
-  Dim sr_Array() As ShapeProperties
-  Dim ret_Array() As Long
-  ReDim ret_Array(1 To size)
-  ReDim sr_Array(1 To size)
-  
-  For Each s In sr
-    sp.Item = sr.IndexOf(s)
-    sp.StaticID = s.StaticID
-    sp.lx = s.LeftX: sp.rx = s.RightX
-    sp.by = s.BottomY: sp.ty = s.topY
-    sp.cx = s.CenterX: sp.cy = s.CenterY
-    sp.sw = s.SizeWidth: sp.sh = s.SizeHeight
-    sr_Array(sp.Item) = sp
-  Next s
-
-  '// 在VBA中数组的索引从1开始, 将数组的地址传递给函数需要Arr(1)方式
-  '// C/C++ 函数定义 int __stdcall SortByItem(ShapeProperties* sr_Array, int size, SortItem Sort_By, int* ret_Array)
-  '// sr_Array首地址，size 长度， Sort_By 排序方式, 返回数组 ret_Array
-  ret = sort_byitem(sr_Array(1), size, Sort_By, ret_Array(1))
-  
-  Debug.Print ret, size
-  If ret = size Then
-    Dim srcp As New ShapeRange, i As Integer
-    For i = 1 To size
-      srcp.Add sr(ret_Array(i))
-'     Debug.Print i
-    Next i
-    
-    Set ShapeRange_To_Sort_Array = srcp
-  End If
-  
-ErrorHandler:
-
-End Function
-
-
-
-
+Attribute VB_Name = "ALGO"
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+'// Algorithm 模块
+#If VBA7 Then
+'// For CorelDRAW X6-2023  62bit
+'// Private Declare PtrSafe Function sort_byitem Lib "C:\TSP\lyvba.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
+'//                       ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
+#Else
+'// For CorelDRAW X4  32bit
+Declare Function sort_byitem Lib "C:\TSP\lyvba32.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
+                      ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
+#End If
+
+Type ShapeProperties
+  Item As Long                 '// ShapeRange.Item
+  StaticID As Long             '// Shape.StaticID
+  lx As Double: rx As Double   '// s.LeftX  s.RightX  s.BottomY  s.TopY
+  by As Double: ty As Double
+  cx As Double: cy As Double   '// s.CenterX  s.CenterY s.SizeWidth s.SizeHeight
+  sw As Double: sh As Double
+End Type
+
+Enum SortItem
+  stlx
+  strx
+  stby
+  stty
+  stcx
+  stcy
+  stsw
+  stsh
+  Area
+  topWt_left
+End Enum
+
+Private Sub Test_Sort_ShapeRange()
+  API.BeginOpt
+  Dim sr As ShapeRange, ssr As ShapeRange
+  Dim s As Shape
+  Set sr = ActiveSelectionRange
+  Set ssr = ShapeRange_To_Sort_Array(sr, topWt_left)
+
+  '// s 调整次序
+  For Each s In ssr
+    s.OrderToFront
+  Next s
+
+  MsgBox "ShapeRange_SortItem:" & " " & topWt_left & "  枚举值"
+  API.EndOpt
+End Sub
+
+
+Public Function X4_Sort_ShapeRange(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
+  Set X4_Sort_ShapeRange = ShapeRange_To_Sort_Array(sr, Sort_By)
+End Function
+
+'// 映射 ShapeRange 到 Array 然后调用 DLL库排序
+Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
+'  On Error GoTo ErrorHandler
+  Dim sp As ShapeProperties
+  Dim size As Long, ret As Long
+  Dim s As Shape
+  size = sr.Count
+  
+  Dim sr_Array() As ShapeProperties
+  Dim ret_Array() As Long
+  ReDim ret_Array(1 To size)
+  ReDim sr_Array(1 To size)
+  
+  For Each s In sr
+    sp.Item = sr.IndexOf(s)
+    sp.StaticID = s.StaticID
+    sp.lx = s.LeftX: sp.rx = s.RightX
+    sp.by = s.BottomY: sp.ty = s.topY
+    sp.cx = s.CenterX: sp.cy = s.CenterY
+    sp.sw = s.SizeWidth: sp.sh = s.SizeHeight
+    sr_Array(sp.Item) = sp
+  Next s
+
+  '// 在VBA中数组的索引从1开始, 将数组的地址传递给函数需要Arr(1)方式
+  '// C/C++ 函数定义 int __stdcall SortByItem(ShapeProperties* sr_Array, int size, SortItem Sort_By, int* ret_Array)
+  '// sr_Array首地址，size 长度， Sort_By 排序方式, 返回数组 ret_Array
+  ret = sort_byitem(sr_Array(1), size, Sort_By, ret_Array(1))
+  
+  Debug.Print ret, size
+  If ret = size Then
+    Dim srcp As New ShapeRange, i As Integer
+    For i = 1 To size
+      srcp.Add sr(ret_Array(i))
+'     Debug.Print i
+    Next i
+    
+    Set ShapeRange_To_Sort_Array = srcp
+  End If
+  
+ErrorHandler:
+
+End Function
+
+
+
+

API.bas

@@ -1,259 +1,259 @@
-Attribute VB_Name = "API"
-'// This is free and unencumbered software released into the public domain.
-'// For more information, please refer to  https://github.com/hongwenjun
-
-'// CorelDRAW 窗口刷新优化和关闭
-Public Function BeginOpt(Optional ByVal name As String = "Undo")
-  EventsEnabled = False
-  ActiveDocument.BeginCommandGroup name
-' ActiveDocument.SaveSettings
-  ActiveDocument.Unit = cdrMillimeter
-  Optimization = True
-' ActiveDocument.PreserveSelection = False
-End Function
-
-Public Function EndOpt()
-' ActiveDocument.PreserveSelection = True
-' ActiveDocument.RestoreSettings
-  EventsEnabled = True
-  Optimization = False
-  EventsEnabled = True
-  ActiveDocument.ReferencePoint = cdrBottomLeft
-  Application.Refresh
-  ActiveDocument.EndCommandGroup
-End Function
-
-Public Function Speak_Msg(message As String)
-  Speak_Help = Val(GetSetting("LYVBA", "Settings", "SpeakHelp", "0"))     '// 关停语音功能
-  
-  If Val(Speak_Help) = 1 Then
-    Dim sapi
-    Set sapi = CreateObject("sapi.spvoice")
-    sapi.Speak message
-  Else
-    ' 不说话
-  End If
-
-End Function
-
-Public Function GetSet(s As String)
-  Bleed = Val(GetSetting("LYVBA", "Settings", "Bleed", "2.0"))
-  Line_len = Val(GetSetting("LYVBA", "Settings", "Line_len", "3.0"))
-  Outline_Width = Val(GetSetting("LYVBA", "Settings", "Outline_Width", "0.2"))
-' Debug.Print Bleed, Line_len, Outline_Width
-
-  If s = "Bleed" Then
-    GetSet = Bleed
-  ElseIf s = "Line_len" Then
-    GetSet = Line_len
-  ElseIf s = "Outline_Width" Then
-    GetSet = Outline_Width
-  End If
-  
-End Function
-
-Public Function Create_Tolerance() As Double
-  Dim text As String
-  If GlobalUserData.Exists("Tolerance", 1) Then
-    text = GlobalUserData("Tolerance", 1)
-  End If
-  text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
-  If text = "" Then Exit Function
-  GlobalUserData("Tolerance", 1) = text
-  Create_Tolerance = Val(text)
-End Function
-
-Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As Double
-  Dim text As String
-  If GlobalUserData.Exists("SpaceWidth", 1) Then
-    text = GlobalUserData("SpaceWidth", 1)
-    If OnlyRead Then
-      Set_Space_Width = Val(text)
-      Exit Function
-    End If
-  End If
-  text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
-  If text = "" Then Exit Function
-  GlobalUserData("SpaceWidth", 1) = text
-  Set_Space_Width = Val(text)
-End Function
-
-'// 获得剪贴板文本字符
-Public Function GetClipBoardString() As String
-  On Error Resume Next
-  Dim MyData As New DataObject
-  GetClipBoardString = ""
-  MyData.GetFromClipboard
-  GetClipBoardString = MyData.GetText
-  Set MyData = Nothing
-End Function
-
-'// 文本字符复制到剪贴板
-Public Function WriteClipBoard(ByVal s As String)
-  On Error Resume Next
-
-' VBA_WIN10(vba7) 使用PutInClipboard乱码解决办法
-#If VBA7 Then
-  With CreateObject("Forms.TextBox.1")
-    .MultiLine = True
-    .text = s
-    .SelStart = 0
-    .SelLength = .TextLength
-    .Copy
-  End With
-#Else
-  Dim MyData As New DataObject
-  MyData.SetText s
-  MyData.PutInClipboard
-#End If
-End Function
-
-'// 换行转空格 多个空格换成一个空格
-Public Function Newline_to_Space(ByVal str As String) As String
-  str = VBA.Replace(str, Chr(13), " ")
-  str = VBA.Replace(str, Chr(9), " ")
-  Do While InStr(str, "  ")
-      str = VBA.Replace(str, "  ", " ")
-  Loop
-  Newline_to_Space = str
-End Function
-
-'// 获得数组元素个数
-Public Function arrlen(src As Variant) As Integer
-  On Error Resume Next '空意味着 0 长度
-  arrlen = (UBound(src) - LBound(src))
-End Function
-
-'// 对数组进行排序[单维]
-Public Function ArraySort(src As Variant) As Variant
-  Dim out As Long, i As Long, tmp As Variant
-  For out = LBound(src) To UBound(src) - 1
-    For i = out + 1 To UBound(src)
-      If src(out) > src(i) Then
-        tmp = src(i): src(i) = src(out): src(out) = tmp
-      End If
-    Next i
-  Next out
-  
-  ArraySort = src
-End Function
-
-'//  把一个数组倒序
-Public Function ArrayReverse(arr)
-    Dim i As Integer, n As Integer
-    n = UBound(arr)
-    Dim P(): ReDim P(n)
-    For i = 0 To n
-        P(i) = arr(n - i)
-    Next
-    ArrayReverse = P
-End Function
-
-'// 测试数组排序
-Private Function test_ArraySort()
-  Dim arr As Variant, i As Integer
-  arr = Array(5, 4, 3, 2, 1, 9, 999, 33)
-  For i = 0 To arrlen(arr) - 1
-    Debug.Print arr(i);
-  Next i
-  Debug.Print arrlen(arr)
-  ArraySort arr
-  For i = 0 To arrlen(arr) - 1
-    Debug.Print arr(i);
-  Next i
-End Function
-
-'// 两点连线的角度：返回角度(相对于X轴的角度)
-'// p为末点，O为始点
-Public Function alfaPP(P, o)
-    Dim pi As Double: pi = 4 * Atn(1)
-    Dim beta As Double
-    If P(0) = o(0) And P(1) = o(1) Then '二点重合
-        alfaPP = 0
-        Exit Function
-    ElseIf P(0) = o(0) And P(1) > o(1) Then
-        beta = pi / 2
-    ElseIf P(0) = o(0) And P(1) < o(1) Then
-        beta = -pi / 2
-    ElseIf P(1) = o(1) And P(0) < o(0) Then
-        beta = pi
-    ElseIf P(1) = o(1) And P(0) > o(0) Then
-        beta = 0
-    Else
-        beta = Atn((P(1) - o(1)) / VBA.Abs(P(0) - o(0)))
-        If P(1) > o(1) And P(0) < o(0) Then
-            beta = pi - beta
-        ElseIf P(1) < o(1) And P(0) < o(0) Then
-            beta = -(pi + beta)
-        End If
-    End If
-    alfaPP = beta * 180 / pi
-End Function
-
-'// 求过P点到线段AB上的垂足点(XY平面内的二维计算)
-Public Function pFootInXY(P, a, b)
-    If a(0) = b(0) Then
-        pFootInXY = Array(a(0), P(1), 0#): Exit Function
-    End If
-    If a(1) = b(1) Then
-        pFootInXY = Array(P(0), a(1), 0#): Exit Function
-    End If
-    Dim aa, bb, c, d, x, y
-    aa = (a(1) - b(1)) / (a(0) - b(0))
-    bb = a(1) - aa * a(0)
-    c = -(a(0) - b(0)) / (a(1) - b(1))
-    d = P(1) - c * P(0)
-    x = (d - bb) / (aa - c)
-    y = aa * x + bb
-    pFootInXY = Array(x, y, 0#)
-End Function
-
-
-Public Function FindAllShapes() As ShapeRange
-  Dim s As Shape
-  Dim srPowerClipped As New ShapeRange
-  Dim sr As ShapeRange, srAll As New ShapeRange
-  
-  If ActiveSelection.Shapes.Count > 0 Then
-    Set sr = ActiveSelection.Shapes.FindShapes()
-  Else
-    Set sr = ActivePage.Shapes.FindShapes()
-  End If
-  
-  Do
-    For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
-        srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
-    Next s
-    srAll.AddRange sr
-    sr.RemoveAll
-    sr.AddRange srPowerClipped
-    srPowerClipped.RemoveAll
-  Loop Until sr.Count = 0
-  
-  Set FindAllShapes = srAll
-End Function
-
-' ************* 函数模块 ************* '
-Public Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
-     Dim fso
-     Set fso = CreateObject("Scripting.FileSystemObject")
-     ExistsFile_UseFso = fso.FileExists(strPath)
-     Set fso = Nothing
-End Function
-
-Public Function test_sapi()
-  Dim message, sapi
-  MsgBox ("Please use the headset and listen to what I have to say...")
-  message = "This is a simple voice test on your Microsoft Windows."
-  Set sapi = CreateObject("sapi.spvoice")
-  sapi.Speak message
-End Function
-
-
-' Public Function WebHelp(url As String)
-'  Dim h As Longer, r As Long
-'  h = FindWindow(vbNullString, "Toolbar")
-'  r = ShellExecute(h, "", url, "", "", 1)
-' End Function
-
-
+Attribute VB_Name = "API"
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+'// CorelDRAW 窗口刷新优化和关闭
+Public Function BeginOpt(Optional ByVal name As String = "Undo")
+  EventsEnabled = False
+  ActiveDocument.BeginCommandGroup name
+' ActiveDocument.SaveSettings
+  ActiveDocument.Unit = cdrMillimeter
+  Optimization = True
+' ActiveDocument.PreserveSelection = False
+End Function
+
+Public Function EndOpt()
+' ActiveDocument.PreserveSelection = True
+' ActiveDocument.RestoreSettings
+  EventsEnabled = True
+  Optimization = False
+  EventsEnabled = True
+  ActiveDocument.ReferencePoint = cdrBottomLeft
+  Application.Refresh
+  ActiveDocument.EndCommandGroup
+End Function
+
+Public Function Speak_Msg(message As String)
+  Speak_Help = Val(GetSetting("LYVBA", "Settings", "SpeakHelp", "0"))     '// 关停语音功能
+  
+  If Val(Speak_Help) = 1 Then
+    Dim sapi
+    Set sapi = CreateObject("sapi.spvoice")
+    sapi.Speak message
+  Else
+    ' 不说话
+  End If
+
+End Function
+
+Public Function GetSet(s As String)
+  Bleed = Val(GetSetting("LYVBA", "Settings", "Bleed", "2.0"))
+  Line_len = Val(GetSetting("LYVBA", "Settings", "Line_len", "3.0"))
+  Outline_Width = Val(GetSetting("LYVBA", "Settings", "Outline_Width", "0.2"))
+' Debug.Print Bleed, Line_len, Outline_Width
+
+  If s = "Bleed" Then
+    GetSet = Bleed
+  ElseIf s = "Line_len" Then
+    GetSet = Line_len
+  ElseIf s = "Outline_Width" Then
+    GetSet = Outline_Width
+  End If
+  
+End Function
+
+Public Function Create_Tolerance() As Double
+  Dim text As String
+  If GlobalUserData.Exists("Tolerance", 1) Then
+    text = GlobalUserData("Tolerance", 1)
+  End If
+  text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
+  If text = "" Then Exit Function
+  GlobalUserData("Tolerance", 1) = text
+  Create_Tolerance = Val(text)
+End Function
+
+Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As Double
+  Dim text As String
+  If GlobalUserData.Exists("SpaceWidth", 1) Then
+    text = GlobalUserData("SpaceWidth", 1)
+    If OnlyRead Then
+      Set_Space_Width = Val(text)
+      Exit Function
+    End If
+  End If
+  text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
+  If text = "" Then Exit Function
+  GlobalUserData("SpaceWidth", 1) = text
+  Set_Space_Width = Val(text)
+End Function
+
+'// 获得剪贴板文本字符
+Public Function GetClipBoardString() As String
+  On Error Resume Next
+  Dim MyData As New DataObject
+  GetClipBoardString = ""
+  MyData.GetFromClipboard
+  GetClipBoardString = MyData.GetText
+  Set MyData = Nothing
+End Function
+
+'// 文本字符复制到剪贴板
+Public Function WriteClipBoard(ByVal s As String)
+  On Error Resume Next
+
+' VBA_WIN10(vba7) 使用PutInClipboard乱码解决办法
+#If VBA7 Then
+  With CreateObject("Forms.TextBox.1")
+    .MultiLine = True
+    .text = s
+    .SelStart = 0
+    .SelLength = .TextLength
+    .Copy
+  End With
+#Else
+  Dim MyData As New DataObject
+  MyData.SetText s
+  MyData.PutInClipboard
+#End If
+End Function
+
+'// 换行转空格 多个空格换成一个空格
+Public Function Newline_to_Space(ByVal str As String) As String
+  str = VBA.Replace(str, Chr(13), " ")
+  str = VBA.Replace(str, Chr(9), " ")
+  Do While InStr(str, "  ")
+      str = VBA.Replace(str, "  ", " ")
+  Loop
+  Newline_to_Space = str
+End Function
+
+'// 获得数组元素个数
+Public Function arrlen(src As Variant) As Integer
+  On Error Resume Next '空意味着 0 长度
+  arrlen = (UBound(src) - LBound(src))
+End Function
+
+'// 对数组进行排序[单维]
+Public Function ArraySort(src As Variant) As Variant
+  Dim out As Long, i As Long, tmp As Variant
+  For out = LBound(src) To UBound(src) - 1
+    For i = out + 1 To UBound(src)
+      If src(out) > src(i) Then
+        tmp = src(i): src(i) = src(out): src(out) = tmp
+      End If
+    Next i
+  Next out
+  
+  ArraySort = src
+End Function
+
+'//  把一个数组倒序
+Public Function ArrayReverse(arr)
+    Dim i As Integer, n As Integer
+    n = UBound(arr)
+    Dim P(): ReDim P(n)
+    For i = 0 To n
+        P(i) = arr(n - i)
+    Next
+    ArrayReverse = P
+End Function
+
+'// 测试数组排序
+Private Function test_ArraySort()
+  Dim arr As Variant, i As Integer
+  arr = Array(5, 4, 3, 2, 1, 9, 999, 33)
+  For i = 0 To arrlen(arr) - 1
+    Debug.Print arr(i);
+  Next i
+  Debug.Print arrlen(arr)
+  ArraySort arr
+  For i = 0 To arrlen(arr) - 1
+    Debug.Print arr(i);
+  Next i
+End Function
+
+'// 两点连线的角度：返回角度(相对于X轴的角度)
+'// p为末点，O为始点
+Public Function alfaPP(P, o)
+    Dim pi As Double: pi = 4 * Atn(1)
+    Dim beta As Double
+    If P(0) = o(0) And P(1) = o(1) Then '二点重合
+        alfaPP = 0
+        Exit Function
+    ElseIf P(0) = o(0) And P(1) > o(1) Then
+        beta = pi / 2
+    ElseIf P(0) = o(0) And P(1) < o(1) Then
+        beta = -pi / 2
+    ElseIf P(1) = o(1) And P(0) < o(0) Then
+        beta = pi
+    ElseIf P(1) = o(1) And P(0) > o(0) Then
+        beta = 0
+    Else
+        beta = Atn((P(1) - o(1)) / VBA.Abs(P(0) - o(0)))
+        If P(1) > o(1) And P(0) < o(0) Then
+            beta = pi - beta
+        ElseIf P(1) < o(1) And P(0) < o(0) Then
+            beta = -(pi + beta)
+        End If
+    End If
+    alfaPP = beta * 180 / pi
+End Function
+
+'// 求过P点到线段AB上的垂足点(XY平面内的二维计算)
+Public Function pFootInXY(P, a, b)
+    If a(0) = b(0) Then
+        pFootInXY = Array(a(0), P(1), 0#): Exit Function
+    End If
+    If a(1) = b(1) Then
+        pFootInXY = Array(P(0), a(1), 0#): Exit Function
+    End If
+    Dim aa, bb, c, d, x, y
+    aa = (a(1) - b(1)) / (a(0) - b(0))
+    bb = a(1) - aa * a(0)
+    c = -(a(0) - b(0)) / (a(1) - b(1))
+    d = P(1) - c * P(0)
+    x = (d - bb) / (aa - c)
+    y = aa * x + bb
+    pFootInXY = Array(x, y, 0#)
+End Function
+
+
+Public Function FindAllShapes() As ShapeRange
+  Dim s As Shape
+  Dim srPowerClipped As New ShapeRange
+  Dim sr As ShapeRange, srAll As New ShapeRange
+  
+  If ActiveSelection.Shapes.Count > 0 Then
+    Set sr = ActiveSelection.Shapes.FindShapes()
+  Else
+    Set sr = ActivePage.Shapes.FindShapes()
+  End If
+  
+  Do
+    For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
+        srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
+    Next s
+    srAll.AddRange sr
+    sr.RemoveAll
+    sr.AddRange srPowerClipped
+    srPowerClipped.RemoveAll
+  Loop Until sr.Count = 0
+  
+  Set FindAllShapes = srAll
+End Function
+
+' ************* 函数模块 ************* '
+Public Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
+     Dim fso
+     Set fso = CreateObject("Scripting.FileSystemObject")
+     ExistsFile_UseFso = fso.FileExists(strPath)
+     Set fso = Nothing
+End Function
+
+Public Function test_sapi()
+  Dim message, sapi
+  MsgBox ("Please use the headset and listen to what I have to say...")
+  message = "This is a simple voice test on your Microsoft Windows."
+  Set sapi = CreateObject("sapi.spvoice")
+  sapi.Speak message
+End Function
+
+
+' Public Function WebHelp(url As String)
+'  Dim h As Longer, r As Long
+'  h = FindWindow(vbNullString, "Toolbar")
+'  r = ShellExecute(h, "", url, "", "", 1)
+' End Function
+
+

AverageDistance.bas

@@ -1,39 +1,39 @@
-Attribute VB_Name = "AverageDistance"
-Public AutoDistribute_Key As Boolean
-Public first_StaticID As Long
-
-'// 选择的物件平均距离
-Public Function Average_Distance()
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  
-  Dim sr As ShapeRange
-  Set sr = ActiveSelectionRange
-  sr.Sort "@shape1.left<@shape2.left"
-
-  Distribute_Shapes sr
-  
-ErrorHandler:
-  API.EndOpt
-End Function
-
-Private Function Distribute_Shapes(sr As ShapeRange)
-  Dim first As Double, last As Double
-  Dim interval As Double, currentPoint As Double
-  Dim total As Integer
-  Dim sh As Shape
-  
-  first_StaticID = sr.FirstShape.StaticID
-  total = sr.Count
-  first = sr.FirstShape.CenterX
-  last = sr.LastShape.CenterX
-  interval = (last - first) / (total - 1)
-  currentPoint = first
-
-
-  For Each sh In sr
-    sh.CenterY = sr.FirstShape.CenterY
-    sh.CenterX = currentPoint
-    currentPoint = currentPoint + interval
-  Next sh
-End Function
+Attribute VB_Name = "AverageDistance"
+Public AutoDistribute_Key As Boolean
+Public first_StaticID As Long
+
+'// 选择的物件平均距离
+Public Function Average_Distance()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  sr.Sort "@shape1.left<@shape2.left"
+
+  Distribute_Shapes sr
+  
+ErrorHandler:
+  API.EndOpt
+End Function
+
+Private Function Distribute_Shapes(sr As ShapeRange)
+  Dim first As Double, last As Double
+  Dim interval As Double, currentPoint As Double
+  Dim total As Integer
+  Dim sh As Shape
+  
+  first_StaticID = sr.FirstShape.StaticID
+  total = sr.Count
+  first = sr.FirstShape.CenterX
+  last = sr.LastShape.CenterX
+  interval = (last - first) / (total - 1)
+  currentPoint = first
+
+
+  For Each sh In sr
+    sh.CenterY = sr.FirstShape.CenterY
+    sh.CenterX = currentPoint
+    currentPoint = currentPoint + interval
+  Next sh
+End Function

Box.bas

@@ -1,358 +1,358 @@
-Attribute VB_Name = "box"
-'// This is free and unencumbered software released into the public domain.
-'// For more information, please refer to  https://github.com/hongwenjun
-
-Public Function Simple_box_five(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
-  Dim sr As New ShapeRange, wing As New ShapeRange, BottomWing As ShapeRange
-  Dim sh As Shape
-  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
-  
-  '// 绘制主体上下盖矩形
-  Set mainRect_aw = ActiveLayer.CreateRectangle(0, 0, w, h)
-  Set mainRect_al = ActiveLayer.CreateRectangle(0, 0, l, h)
-  mainRect_al.Move l1x, 0
-  Set mainRect_bw = ActiveLayer.CreateRectangle(0, 0, w, h)
-  mainRect_bw.Move l2x, 0
-  Set mainRect_bl = ActiveLayer.CreateRectangle(0, 0, l, h)
-  mainRect_bl.Move l3x, 0
-
-  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
-  topRect.Move l1x, h
-
-  '// 绘制Box 圆角矩形插口
-  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 75, 75)
-  top_RoundRect.Move l1x, h + w
-  Set Bond = DrawBond(b, h, l4x, 0)
-
-  Set SealLine = Draw_SealLine(l, l1x, h + w - 1)
-  Set top_RoundRect = top_RoundRect.Weld(topRect, False, False)
-
-  '// 绘制box 2个翅膀
-  Set sh = DrawWing(w, (w + b) / 2 - 2)
-  wing.Add sh.Duplicate(0, h)
-  wing.Add sh.Duplicate(l2x, h)
-  wing(2).Flip cdrFlipHorizontal
-
-  '// 绘制 Box 底下翅膀 BottomWing
-  Set BottomWing = DrawBottomWing(l, w, b)
-
-  '// 添加到物件组，设置轮廓色 C100
-  sr.Add mainRect_aw: sr.Add mainRect_al: sr.Add mainRect_bw: sr.Add mainRect_bl
-  sr.Add Bond: sr.Add top_RoundRect
-  sr.AddRange BottomWing
-  sr.AddRange wing: sh.Delete
-  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
-  sr.Add SealLine
-  
-  sr.CreateSelection: sr.Group
-End Function
-
-Private Function DrawBottomWing(ByVal l As Double, ByVal w As Double, ByVal b As Double) As ShapeRange
-  Dim sr As New ShapeRange, s As Shape
-  Dim sp As SubPath, crv(3) As Curve
-  
-  w_2 = w / 2#
-  block = w * 0.275 + w * ((l - w) / w * 0.15)
-  bb = block + b: If bb < w_2 Then bb = w_2
-
-  '// 绘制 Box 底下翅膀 BottomWing
-  Set crv(1) = Application.CreateCurve(ActiveDocument)
-  Set sp = crv(1).CreateSubPath(0, 0)
-  sp.AppendLineSegment w_2, block
-  sp.AppendLineSegment w_2, bb - 5
-  sp.AppendCurveSegment2 w_2 + 5, bb, w_2, bb - 2.5, w_2 + 2.5, bb
-  sp.AppendLineSegment w, bb
-  sp.AppendLineSegment w, 0
-  sp.Closed = True
-  sr.Add ActiveLayer.CreateCurve(crv(1))
-  
-  Set crv(2) = Application.CreateCurve(ActiveDocument)
-  Set sp = crv(2).CreateSubPath(0, 0)
-  sp.AppendLineSegment w_2, block
-  sp.AppendLineSegment w_2 + b - 5, block
-  sp.AppendCurveSegment2 w_2 + b, block + 5, w_2 + b - 2.5, block, w_2 + b, block + 2.5
-  sp.AppendLineSegment w_2 + b, l - block - 5
-  sp.AppendCurveSegment2 w_2 + b - 5, l - block, w_2 + b, l - block - 2.5, w_2 + b - 2.5, l - block
-  
-  sp.AppendLineSegment w_2, l - block
-  sp.AppendLineSegment 0, l
-  sp.Closed = True
-  sr.Add ActiveLayer.CreateCurve(crv(2))
-  
-  Set crv(3) = Application.CreateCurve(ActiveDocument)
-  Set sp = crv(3).CreateSubPath(0, 0)
-  sp.AppendLineSegment 0, l
-  sp.AppendLineSegment w_2 + b, l
-  sp.AppendLineSegment w_2 + b, l - block + 5
-  sp.AppendCurveSegment2 w_2 + b - 5, l - block, w_2 + b, l - block + 2.5, w_2 + b - 2.5, l - block
-  sp.AppendLineSegment w_2, l - block
-  sp.AppendLineSegment w_2, block
-  sp.AppendLineSegment w_2 + b - 5, block
-  sp.AppendCurveSegment2 w_2 + b, block - 5, w_2 + b - 2.5, block, w_2 + b, block - 2.5
-  sp.AppendLineSegment w_2 + b, 0
-  sp.Closed = True
-  sr.Add ActiveLayer.CreateCurve(crv(3))
-  
-  '// 移动到适合的地方
-  sr(1).Move 0, -bb: sr(1).Rotate 180
-  Set s = sr(1).Duplicate(0, 0): sr.Add s
-  s.Flip cdrFlipHorizontal: s.Move w + l, 0
-  
-  sr(2).Rotate -90: sr(3).Rotate -90
-  sr(2).LeftX = 2 * w + l: sr(3).LeftX = w
-  sr(2).topY = 0: sr(3).topY = 0
-  Set DrawBottomWing = sr
-  
-End Function
-
-
-Public Function Simple_box_four(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
-  Dim sr As New ShapeRange, wing As New ShapeRange
-  Dim sh As Shape
-  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
-  
-  '// 绘制主体上下盖矩形
-  Set mainRect_aw = ActiveLayer.CreateRectangle(0, 0, w, h)
-  Set mainRect_al = ActiveLayer.CreateRectangle(0, 0, l, h)
-  mainRect_al.Move l1x, 0
-  Set mainRect_bw = ActiveLayer.CreateRectangle(0, 0, w, h)
-  mainRect_bw.Move l2x, 0
-  Set mainRect_bl = ActiveLayer.CreateRectangle(0, 0, l, h)
-  mainRect_bl.Move l3x, 0
-
-  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
-  topRect.Move l1x, h
-  Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
-  bottomRect.Move l3x, -w
-  
-  '// 绘制Box 圆角矩形插口
-  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 75, 75)
-  top_RoundRect.Move l1x, h + w
-  Set bottom_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 0, 0, 75, 75)
-  bottom_RoundRect.Move l3x, -w - b
-  Set Bond = DrawBond(b, h, l4x, 0)
-  
-  Set SealLine = Draw_SealLine(l, l1x, h + w - 1)
-  Set SealLine2 = Draw_SealLine(l, l3x, -w - 1)
-  SealLine2.Rotate 180
-  
-  '// 绘制box 四个翅膀
-  Set sh = DrawWing(w, (w + b) / 2 - 2)
-  wing.Add sh.Duplicate(0, h)
-  wing.Add sh.Duplicate(l2x, h)
-  wing.Add sh.Duplicate(0, -sh.SizeHeight)
-  wing.Add sh.Duplicate(l2x, -sh.SizeHeight)
-  wing(2).Flip cdrFlipHorizontal
-  wing(3).Rotate 180
-  wing(4).Flip cdrFlipVertical
-
-  Set top_RoundRect = top_RoundRect.Weld(topRect, False, False)
-  Set bottom_RoundRect = bottom_RoundRect.Weld(bottomRect, False, False)
-
-  '// 添加到物件组，设置轮廓色 C100
-  sr.Add mainRect_aw: sr.Add mainRect_al: sr.Add mainRect_bw: sr.Add mainRect_bl
-  sr.Add Bond: sr.Add top_RoundRect: sr.Add bottom_RoundRect
-  sr.AddRange wing: sh.Delete
-  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
-  sr.Add SealLine: sr.Add SealLine2
-  sr.CreateSelection: sr.Group
-  
-End Function
-
-Public Function input_box_lwh() As Variant
-  Dim str, arr, n
-  str = InputBox("请输入长x宽x高，使用空格 * x 间隔" & vbNewLine & "鼠标左键-右键-Ctrl三种样式", "盒子长宽高", "120 x 100 x 150 mm") & " "
-  str = Newline_to_Space(str)
-
-  ' 替换 mm x * 换行 TAB 为空格
-  str = VBA.Replace(str, "mm", " ")
-  str = VBA.Replace(str, "x", " ")
-  str = VBA.Replace(str, "X", " ")
-  str = VBA.Replace(str, "*", " ")
-
-  '// 换行转空格 多个空格换成一个空格
-  str = API.Newline_to_Space(str)
-
-  arr = Split(str)
-  arr(0) = Val(arr(0))
-  arr(1) = Val(arr(1))
-  arr(2) = Val(arr(2))
-  arr(3) = Val(arr(3))
-  input_box_lwh = arr
-End Function
-
-Public Function Simple_box_three(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
-  ActiveDocument.Unit = cdrMillimeter
-  Dim sr As New ShapeRange, wing As New ShapeRange
-  Dim sh As Shape
-  boxL = 2 * l + 2 * w + b: boxH = h
-  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
-  
-  '// 绘制主体上下盖矩形
-  Set mainRect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
-  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
-  topRect.Move l1x, h
-  Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
-  bottomRect.Move l3x, -w
-  
-  '// 绘制Box 圆角矩形插口
-  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 75, 75)
-  top_RoundRect.Move l1x, h + w
-  Set bottom_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 0, 0, 75, 75)
-  bottom_RoundRect.Move l3x, -w - b
-  
-  '// 绘制box 四个翅膀
-  Set sh = DrawWing(w, (w + b) / 2 - 2)
-  wing.Add sh.Duplicate(0, h)
-  wing.Add sh.Duplicate(l2x, h)
-  wing.Add sh.Duplicate(0, -sh.SizeHeight)
-  wing.Add sh.Duplicate(l2x, -sh.SizeHeight)
-  wing(2).Flip cdrFlipHorizontal
-  wing(3).Rotate 180
-  wing(4).Flip cdrFlipVertical
-
-  Set top_RoundRect = top_RoundRect.Weld(topRect, False, False)
-  Set bottom_RoundRect = bottom_RoundRect.Weld(bottomRect, False, False)
-  
-  '// 添加到物件组，设置轮廓色 C100
-  sr.Add mainRect: sr.Add top_RoundRect: sr.Add bottom_RoundRect
-  sr.AddRange wing: sh.Delete
-  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
-  
-  '// 绘制尺寸刀痕线
-  Set sl1 = DrawLine(l1x, 0, l1x, h)
-  Set sl2 = DrawLine(l2x, 0, l2x, h)
-  Set sl3 = DrawLine(l3x, 0, l3x, h)
-  Set sl4 = DrawLine(l4x, 0, l4x, h)
-  Set SealLine = Draw_SealLine(l, l1x, h + w - 1)
-  Set SealLine2 = Draw_SealLine(l, l3x, -w - 1)
-  SealLine2.Rotate 180
-  
-  '// 盒子box 群组
-  sr.Add sl1: sr.Add sl2: sr.Add sl3: sr.Add sl4
-  sr.Add SealLine: sr.Add SealLine2
-  sr.CreateSelection: sr.Group
-  
-End Function
-
-'// 画一条线，设置轮廓色 M100
-Private Function DrawLine(x1, y1, x2, y2) As Shape
-  Set DrawLine = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
-  DrawLine.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 0, 0)
-End Function
-
-'// 绘制封口线
-Private Function Draw_SealLine(ByVal l As Double, ByVal move_x As Double, ByVal move_y As Double) As Shape
-  Dim sp As SubPath, crv As Curve
-  '// 绘制 Box 翅膀 Wing
-  Set crv = Application.CreateCurve(ActiveDocument)
-  Set sp = crv.CreateSubPath(0, 2)
-  sp.AppendLineSegment 4, 2
-  sp.AppendLineSegment 6, 0
-  sp.AppendLineSegment l - 6, 0
-  sp.AppendLineSegment l - 4, 2
-  sp.AppendLineSegment l, 2
-  sp.Closed = False
-  Set Draw_SealLine = ActiveLayer.CreateCurve(crv)
-  Draw_SealLine.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 0, 0)
-  Draw_SealLine.Move move_x, move_y
-End Function
-
-Private Function DrawWing(ByVal w As Double, ByVal h As Double) As Shape
-    Dim sp As SubPath, crv As Curve
-    Dim x As Double, y As Double
-    x = w: y = h
-    
-    '// 绘制 Box 翅膀 Wing
-    Set crv = Application.CreateCurve(ActiveDocument)
-    Set sp = crv.CreateSubPath(0, 0)
-    sp.AppendLineSegment 0, 4
-    sp.AppendLineSegment 2, 6
-    sp.AppendLineSegment 6, y - 2.5
-    sp.AppendCurveSegment2 8.5, y, 6.2, y - 1.25, 7, y
-    sp.AppendLineSegment x - 2, y
-    sp.AppendLineSegment x - 2, 3
-    sp.AppendLineSegment x, 0
-    
-    sp.Closed = True
-    Set DrawWing = ActiveLayer.CreateCurve(crv)
-End Function
-
-Private Function DrawBond(ByVal w As Double, ByVal h As Double, ByVal move_x As Double, ByVal move_y As Double) As Shape
-    Dim sp As SubPath, crv As Curve
-    Dim x As Double, y As Double
-    x = w: y = h
-    
-    '// 绘制 Box 粘合边 Bond
-    Set crv = Application.CreateCurve(ActiveDocument)
-    Set sp = crv.CreateSubPath(0, 0)
-    sp.AppendLineSegment 0, y
-    sp.AppendLineSegment x, y - 5
-    sp.AppendLineSegment x, 5
-
-    sp.Closed = True
-    Set DrawBond = ActiveLayer.CreateCurve(crv)
-    DrawBond.Move move_x, move_y
-End Function
-
-
-Public Function Simple_box_one()
-  ActiveDocument.Unit = cdrMillimeter
-  l = 100: w = 50: h = 70: b = 15
-  boxL = 2 * l + 2 * w + b
-  boxH = h
-  l1x = w
-  l2x = w + l
-  l3x = 2 * w + l
-  l4x = 2 * (w + l)
-  
-  Set Rect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
-  Set sl1 = DrawLine(l1x, 0, l1x, h)
-  Set sl2 = DrawLine(l2x, 0, l2x, h)
-  Set sl3 = DrawLine(l3x, 0, l3x, h)
-  Set sl4 = DrawLine(l4x, 0, l4x, h)
-End Function
-
-Public Function Simple_box_two()
-  ActiveDocument.Unit = cdrMillimeter
-  l = 100: w = 50: h = 70: b = 15
-  boxL = 2 * l + 2 * w + b: boxH = h
-  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
-  
-  Set mainRect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
-  
-  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
-  topRect.Move l1x, h
-  Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
-  bottomRect.Move l3x, -w
-  
-  Set sl1 = DrawLine(l1x, 0, l1x, h)
-  Set sl2 = DrawLine(l2x, 0, l2x, h)
-  Set sl3 = DrawLine(l3x, 0, l3x, h)
-  Set sl4 = DrawLine(l4x, 0, l4x, h)
-End Function
-
-
-Public Function Simple_3Deffect()
-  Dim sr As ShapeRange            '// 定义物件范围
-  Set sr = ActiveSelectionRange   '// 选择3个物件
-  
-  If sr.Count >= 3 Then
-  
-  '// 先上下再左右排序
-#If VBA7 Then
-    sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
-#Else
-    Set ssr = X4_Sort_ShapeRange(sr, topWt_left)
-#End If
-
-    sr(1).Stretch 0.951, 0.525      ' 顶盖物件缩放修正和变形
-    sr(1).Skew 41.7, 7#
-      
-    sr(2).Stretch 0.951, 0.937      ' 正面物件缩放修正和变形
-    sr(2).Skew 0#, 7#
-    
-    sr(3).Stretch 0.468, 0.937      ' 侧面物件缩放修正和变形
-    sr(3).Skew 0#, -45#
-  End If
-End Function
+Attribute VB_Name = "box"
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+Public Function Simple_box_five(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
+  Dim sr As New ShapeRange, wing As New ShapeRange, BottomWing As ShapeRange
+  Dim sh As Shape
+  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
+  
+  '// 绘制主体上下盖矩形
+  Set mainRect_aw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  Set mainRect_al = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_al.Move l1x, 0
+  Set mainRect_bw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  mainRect_bw.Move l2x, 0
+  Set mainRect_bl = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_bl.Move l3x, 0
+
+  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  topRect.Move l1x, h
+
+  '// 绘制Box 圆角矩形插口
+  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 75, 75)
+  top_RoundRect.Move l1x, h + w
+  Set Bond = DrawBond(b, h, l4x, 0)
+
+  Set SealLine = Draw_SealLine(l, l1x, h + w - 1)
+  Set top_RoundRect = top_RoundRect.Weld(topRect, False, False)
+
+  '// 绘制box 2个翅膀
+  Set sh = DrawWing(w, (w + b) / 2 - 2)
+  wing.Add sh.Duplicate(0, h)
+  wing.Add sh.Duplicate(l2x, h)
+  wing(2).Flip cdrFlipHorizontal
+
+  '// 绘制 Box 底下翅膀 BottomWing
+  Set BottomWing = DrawBottomWing(l, w, b)
+
+  '// 添加到物件组，设置轮廓色 C100
+  sr.Add mainRect_aw: sr.Add mainRect_al: sr.Add mainRect_bw: sr.Add mainRect_bl
+  sr.Add Bond: sr.Add top_RoundRect
+  sr.AddRange BottomWing
+  sr.AddRange wing: sh.Delete
+  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
+  sr.Add SealLine
+  
+  sr.CreateSelection: sr.Group
+End Function
+
+Private Function DrawBottomWing(ByVal l As Double, ByVal w As Double, ByVal b As Double) As ShapeRange
+  Dim sr As New ShapeRange, s As Shape
+  Dim sp As SubPath, crv(3) As Curve
+  
+  w_2 = w / 2#
+  block = w * 0.275 + w * ((l - w) / w * 0.15)
+  bb = block + b: If bb < w_2 Then bb = w_2
+
+  '// 绘制 Box 底下翅膀 BottomWing
+  Set crv(1) = Application.CreateCurve(ActiveDocument)
+  Set sp = crv(1).CreateSubPath(0, 0)
+  sp.AppendLineSegment w_2, block
+  sp.AppendLineSegment w_2, bb - 5
+  sp.AppendCurveSegment2 w_2 + 5, bb, w_2, bb - 2.5, w_2 + 2.5, bb
+  sp.AppendLineSegment w, bb
+  sp.AppendLineSegment w, 0
+  sp.Closed = True
+  sr.Add ActiveLayer.CreateCurve(crv(1))
+  
+  Set crv(2) = Application.CreateCurve(ActiveDocument)
+  Set sp = crv(2).CreateSubPath(0, 0)
+  sp.AppendLineSegment w_2, block
+  sp.AppendLineSegment w_2 + b - 5, block
+  sp.AppendCurveSegment2 w_2 + b, block + 5, w_2 + b - 2.5, block, w_2 + b, block + 2.5
+  sp.AppendLineSegment w_2 + b, l - block - 5
+  sp.AppendCurveSegment2 w_2 + b - 5, l - block, w_2 + b, l - block - 2.5, w_2 + b - 2.5, l - block
+  
+  sp.AppendLineSegment w_2, l - block
+  sp.AppendLineSegment 0, l
+  sp.Closed = True
+  sr.Add ActiveLayer.CreateCurve(crv(2))
+  
+  Set crv(3) = Application.CreateCurve(ActiveDocument)
+  Set sp = crv(3).CreateSubPath(0, 0)
+  sp.AppendLineSegment 0, l
+  sp.AppendLineSegment w_2 + b, l
+  sp.AppendLineSegment w_2 + b, l - block + 5
+  sp.AppendCurveSegment2 w_2 + b - 5, l - block, w_2 + b, l - block + 2.5, w_2 + b - 2.5, l - block
+  sp.AppendLineSegment w_2, l - block
+  sp.AppendLineSegment w_2, block
+  sp.AppendLineSegment w_2 + b - 5, block
+  sp.AppendCurveSegment2 w_2 + b, block - 5, w_2 + b - 2.5, block, w_2 + b, block - 2.5
+  sp.AppendLineSegment w_2 + b, 0
+  sp.Closed = True
+  sr.Add ActiveLayer.CreateCurve(crv(3))
+  
+  '// 移动到适合的地方
+  sr(1).Move 0, -bb: sr(1).Rotate 180
+  Set s = sr(1).Duplicate(0, 0): sr.Add s
+  s.Flip cdrFlipHorizontal: s.Move w + l, 0
+  
+  sr(2).Rotate -90: sr(3).Rotate -90
+  sr(2).LeftX = 2 * w + l: sr(3).LeftX = w
+  sr(2).topY = 0: sr(3).topY = 0
+  Set DrawBottomWing = sr
+  
+End Function
+
+
+Public Function Simple_box_four(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
+  Dim sr As New ShapeRange, wing As New ShapeRange
+  Dim sh As Shape
+  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
+  
+  '// 绘制主体上下盖矩形
+  Set mainRect_aw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  Set mainRect_al = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_al.Move l1x, 0
+  Set mainRect_bw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  mainRect_bw.Move l2x, 0
+  Set mainRect_bl = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_bl.Move l3x, 0
+
+  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  topRect.Move l1x, h
+  Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  bottomRect.Move l3x, -w
+  
+  '// 绘制Box 圆角矩形插口
+  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 75, 75)
+  top_RoundRect.Move l1x, h + w
+  Set bottom_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 0, 0, 75, 75)
+  bottom_RoundRect.Move l3x, -w - b
+  Set Bond = DrawBond(b, h, l4x, 0)
+  
+  Set SealLine = Draw_SealLine(l, l1x, h + w - 1)
+  Set SealLine2 = Draw_SealLine(l, l3x, -w - 1)
+  SealLine2.Rotate 180
+  
+  '// 绘制box 四个翅膀
+  Set sh = DrawWing(w, (w + b) / 2 - 2)
+  wing.Add sh.Duplicate(0, h)
+  wing.Add sh.Duplicate(l2x, h)
+  wing.Add sh.Duplicate(0, -sh.SizeHeight)
+  wing.Add sh.Duplicate(l2x, -sh.SizeHeight)
+  wing(2).Flip cdrFlipHorizontal
+  wing(3).Rotate 180
+  wing(4).Flip cdrFlipVertical
+
+  Set top_RoundRect = top_RoundRect.Weld(topRect, False, False)
+  Set bottom_RoundRect = bottom_RoundRect.Weld(bottomRect, False, False)
+
+  '// 添加到物件组，设置轮廓色 C100
+  sr.Add mainRect_aw: sr.Add mainRect_al: sr.Add mainRect_bw: sr.Add mainRect_bl
+  sr.Add Bond: sr.Add top_RoundRect: sr.Add bottom_RoundRect
+  sr.AddRange wing: sh.Delete
+  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
+  sr.Add SealLine: sr.Add SealLine2
+  sr.CreateSelection: sr.Group
+  
+End Function
+
+Public Function input_box_lwh() As Variant
+  Dim str, arr, n
+  str = InputBox("请输入长x宽x高，使用空格 * x 间隔" & vbNewLine & "鼠标左键-右键-Ctrl三种样式", "盒子长宽高", "120 x 100 x 150 mm") & " "
+  str = Newline_to_Space(str)
+
+  ' 替换 mm x * 换行 TAB 为空格
+  str = VBA.Replace(str, "mm", " ")
+  str = VBA.Replace(str, "x", " ")
+  str = VBA.Replace(str, "X", " ")
+  str = VBA.Replace(str, "*", " ")
+
+  '// 换行转空格 多个空格换成一个空格
+  str = API.Newline_to_Space(str)
+
+  arr = Split(str)
+  arr(0) = Val(arr(0))
+  arr(1) = Val(arr(1))
+  arr(2) = Val(arr(2))
+  arr(3) = Val(arr(3))
+  input_box_lwh = arr
+End Function
+
+Public Function Simple_box_three(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
+  ActiveDocument.Unit = cdrMillimeter
+  Dim sr As New ShapeRange, wing As New ShapeRange
+  Dim sh As Shape
+  boxL = 2 * l + 2 * w + b: boxH = h
+  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
+  
+  '// 绘制主体上下盖矩形
+  Set mainRect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
+  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  topRect.Move l1x, h
+  Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  bottomRect.Move l3x, -w
+  
+  '// 绘制Box 圆角矩形插口
+  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 75, 75)
+  top_RoundRect.Move l1x, h + w
+  Set bottom_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 0, 0, 75, 75)
+  bottom_RoundRect.Move l3x, -w - b
+  
+  '// 绘制box 四个翅膀
+  Set sh = DrawWing(w, (w + b) / 2 - 2)
+  wing.Add sh.Duplicate(0, h)
+  wing.Add sh.Duplicate(l2x, h)
+  wing.Add sh.Duplicate(0, -sh.SizeHeight)
+  wing.Add sh.Duplicate(l2x, -sh.SizeHeight)
+  wing(2).Flip cdrFlipHorizontal
+  wing(3).Rotate 180
+  wing(4).Flip cdrFlipVertical
+
+  Set top_RoundRect = top_RoundRect.Weld(topRect, False, False)
+  Set bottom_RoundRect = bottom_RoundRect.Weld(bottomRect, False, False)
+  
+  '// 添加到物件组，设置轮廓色 C100
+  sr.Add mainRect: sr.Add top_RoundRect: sr.Add bottom_RoundRect
+  sr.AddRange wing: sh.Delete
+  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
+  
+  '// 绘制尺寸刀痕线
+  Set sl1 = DrawLine(l1x, 0, l1x, h)
+  Set sl2 = DrawLine(l2x, 0, l2x, h)
+  Set sl3 = DrawLine(l3x, 0, l3x, h)
+  Set sl4 = DrawLine(l4x, 0, l4x, h)
+  Set SealLine = Draw_SealLine(l, l1x, h + w - 1)
+  Set SealLine2 = Draw_SealLine(l, l3x, -w - 1)
+  SealLine2.Rotate 180
+  
+  '// 盒子box 群组
+  sr.Add sl1: sr.Add sl2: sr.Add sl3: sr.Add sl4
+  sr.Add SealLine: sr.Add SealLine2
+  sr.CreateSelection: sr.Group
+  
+End Function
+
+'// 画一条线，设置轮廓色 M100
+Private Function DrawLine(x1, y1, x2, y2) As Shape
+  Set DrawLine = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
+  DrawLine.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 0, 0)
+End Function
+
+'// 绘制封口线
+Private Function Draw_SealLine(ByVal l As Double, ByVal move_x As Double, ByVal move_y As Double) As Shape
+  Dim sp As SubPath, crv As Curve
+  '// 绘制 Box 翅膀 Wing
+  Set crv = Application.CreateCurve(ActiveDocument)
+  Set sp = crv.CreateSubPath(0, 2)
+  sp.AppendLineSegment 4, 2
+  sp.AppendLineSegment 6, 0
+  sp.AppendLineSegment l - 6, 0
+  sp.AppendLineSegment l - 4, 2
+  sp.AppendLineSegment l, 2
+  sp.Closed = False
+  Set Draw_SealLine = ActiveLayer.CreateCurve(crv)
+  Draw_SealLine.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 0, 0)
+  Draw_SealLine.Move move_x, move_y
+End Function
+
+Private Function DrawWing(ByVal w As Double, ByVal h As Double) As Shape
+    Dim sp As SubPath, crv As Curve
+    Dim x As Double, y As Double
+    x = w: y = h
+    
+    '// 绘制 Box 翅膀 Wing
+    Set crv = Application.CreateCurve(ActiveDocument)
+    Set sp = crv.CreateSubPath(0, 0)
+    sp.AppendLineSegment 0, 4
+    sp.AppendLineSegment 2, 6
+    sp.AppendLineSegment 6, y - 2.5
+    sp.AppendCurveSegment2 8.5, y, 6.2, y - 1.25, 7, y
+    sp.AppendLineSegment x - 2, y
+    sp.AppendLineSegment x - 2, 3
+    sp.AppendLineSegment x, 0
+    
+    sp.Closed = True
+    Set DrawWing = ActiveLayer.CreateCurve(crv)
+End Function
+
+Private Function DrawBond(ByVal w As Double, ByVal h As Double, ByVal move_x As Double, ByVal move_y As Double) As Shape
+    Dim sp As SubPath, crv As Curve
+    Dim x As Double, y As Double
+    x = w: y = h
+    
+    '// 绘制 Box 粘合边 Bond
+    Set crv = Application.CreateCurve(ActiveDocument)
+    Set sp = crv.CreateSubPath(0, 0)
+    sp.AppendLineSegment 0, y
+    sp.AppendLineSegment x, y - 5
+    sp.AppendLineSegment x, 5
+
+    sp.Closed = True
+    Set DrawBond = ActiveLayer.CreateCurve(crv)
+    DrawBond.Move move_x, move_y
+End Function
+
+
+Public Function Simple_box_one()
+  ActiveDocument.Unit = cdrMillimeter
+  l = 100: w = 50: h = 70: b = 15
+  boxL = 2 * l + 2 * w + b
+  boxH = h
+  l1x = w
+  l2x = w + l
+  l3x = 2 * w + l
+  l4x = 2 * (w + l)
+  
+  Set Rect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
+  Set sl1 = DrawLine(l1x, 0, l1x, h)
+  Set sl2 = DrawLine(l2x, 0, l2x, h)
+  Set sl3 = DrawLine(l3x, 0, l3x, h)
+  Set sl4 = DrawLine(l4x, 0, l4x, h)
+End Function
+
+Public Function Simple_box_two()
+  ActiveDocument.Unit = cdrMillimeter
+  l = 100: w = 50: h = 70: b = 15
+  boxL = 2 * l + 2 * w + b: boxH = h
+  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
+  
+  Set mainRect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
+  
+  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  topRect.Move l1x, h
+  Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  bottomRect.Move l3x, -w
+  
+  Set sl1 = DrawLine(l1x, 0, l1x, h)
+  Set sl2 = DrawLine(l2x, 0, l2x, h)
+  Set sl3 = DrawLine(l3x, 0, l3x, h)
+  Set sl4 = DrawLine(l4x, 0, l4x, h)
+End Function
+
+
+Public Function Simple_3Deffect()
+  Dim sr As ShapeRange            '// 定义物件范围
+  Set sr = ActiveSelectionRange   '// 选择3个物件
+  
+  If sr.Count >= 3 Then
+  
+  '// 先上下再左右排序
+#If VBA7 Then
+    sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+#Else
+    Set ssr = X4_Sort_ShapeRange(sr, topWt_left)
+#End If
+
+    sr(1).Stretch 0.951, 0.525      ' 顶盖物件缩放修正和变形
+    sr(1).Skew 41.7, 7#
+      
+    sr(2).Stretch 0.951, 0.937      ' 正面物件缩放修正和变形
+    sr(2).Skew 0#, 7#
+    
+    sr(3).Stretch 0.468, 0.937      ' 侧面物件缩放修正和变形
+    sr(3).Skew 0#, -45#
+  End If
+End Function

Form/Form/LinesForm.frm

@@ -0,0 +1,193 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} LinesForm 
+   Caption         =   "LinesForm"
+   ClientHeight    =   2430
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   4680
+   OleObjectBlob   =   "LinesForm.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "LinesForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+'// 插件名称 VBA_UserForm
+Private Const TOOLNAME As String = "LYVBA"
+Private Const SECTION As String = "LinesForm"
+
+'// 用户窗口初始化
+Private Sub UserForm_Initialize()
+
+  With Me
+    .StartUpPosition = 0
+    .Left = Val(GetSetting(TOOLNAME, SECTION, "form_left", 900))
+    .Top = Val(GetSetting(TOOLNAME, SECTION, "form_top", 200))
+  End With
+
+End Sub
+
+
+'// 关闭窗口时保存窗口位置
+Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
+    saveFormPos True
+End Sub
+
+'// 保存窗口位置和加载窗口位置
+Sub saveFormPos(bDoSave As Boolean)
+  If bDoSave Then 'save position
+    SaveSetting TOOLNAME, SECTION, "form_left", Me.Left
+    SaveSetting TOOLNAME, SECTION, "form_top", Me.Top
+  End If
+End Sub
+
+Private Sub MyPen_Click()
+On Error GoTo ErrorHandler
+  API.BeginOpt
+  lines.Nodes_DrawLines
+ErrorHandler:
+  API.EndOpt
+End Sub
+
+
+'// 左键右键Ctrl三键控制
+Private Sub PenDrawLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+On Error GoTo ErrorHandler
+  API.BeginOpt
+  If Button = 2 Then
+    lines.Draw_Multiple_Lines cdrAlignVCenter
+    
+  ElseIf Shift = fmCtrlMask Then
+    lines.Draw_Multiple_Lines cdrAlignHCenter
+  Else
+    lines.Draw_Multiple_Lines 0
+  End If
+ErrorHandler:
+  API.EndOpt
+End Sub
+
+
+'''////  傻瓜火车排列  ////'''
+Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    Tools.Simple_Train_Arrangement 3#
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Simple_Train_Arrangement 0#
+  Else
+    Tools.Simple_Train_Arrangement Set_Space_Width
+  End If
+End Sub
+
+'''////  傻瓜阶梯排列  ////'''
+Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    Tools.Simple_Ladder_Arrangement 3#
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Simple_Ladder_Arrangement 0#
+  Else
+    Tools.Simple_Ladder_Arrangement Set_Space_Width
+  End If
+End Sub
+
+
+Private Sub MakeBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  Dim size As Variant
+  size = input_box_lwh
+  l = size(0): w = size(1): h = size(2): b = size(3)
+  If b = 0 Then b = 15
+  
+  If Button = 2 Then
+    box.Simple_box_five l, w, h, b
+  ElseIf Shift = fmCtrlMask Then
+    box.Simple_box_four l, w, h, b
+  Else
+    box.Simple_box_three l, w, h, b
+  End If
+  
+ErrorHandler:
+  API.EndOpt
+End Sub
+
+Private Sub Cmd_3D_Click()
+  box.Simple_3Deffect
+End Sub
+
+
+'// 角度和旋转工具, 左键左转，右键右转
+Private Sub Rotate_Shapes_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then   '// 右键的代码
+    Shapes_Rotate -90
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    Shapes_Rotate 90
+  Else    '// CTRL的代码
+    Shapes_Rotate -45
+  End If
+End Sub
+
+'// 移动和再制，我们来制作三键控制，左键只移动，右键是反方向，按CTRL 是复制的
+Private Sub Move_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then   '// 右键的代码
+    move_shapes 100, 0
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    move_shapes -100, 0
+  Else    '// CTRL的代码
+    Duplicate_shapes -100, 0
+  End If
+End Sub
+
+Private Sub Move_Up_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then   '// 右键的代码
+    move_shapes 0, -100
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    move_shapes 0, 100
+  Else    '// CTRL的代码
+    Duplicate_shapes 0, 100
+  End If
+End Sub
+
+'// 测量标尺和水平尺
+Private Sub Ruler_Measuring_BT_Click()
+  '// 角度转平
+  Angle_to_Horizon
+End Sub
+
+'// 选择的物件平均距离
+Private Sub Average_Distance_BT_Click()
+  Average_Distance
+End Sub
+
+Private Sub chkAutoDistribute_Click()
+  AutoDistribute_Key = chkAutoDistribute.Value
+End Sub
+
+'// 镜像工具
+Private Sub MirrorLine_Click()
+  Mirror_ByGuide
+End Sub
+
+'// 平行线工具 CTRL 键设置距离
+Private Sub ParallelLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  Dim sp As Double
+  text = GlobalUserData("SpaceWidth", 1)
+  sp = Val(text)
+  If Button = 2 Then   '// 右键的代码
+    Create_Parallel_Lines -sp
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    Create_Parallel_Lines sp
+  Else    '// CTRL的代码
+    Create_Parallel_Lines Set_Space_Width
+  End If
+End Sub
+
+'// 标记镜像参考线
+Private Sub Set_Guide_Click()
+  Set_Guides_Name
+End Sub

Form/Form/ThisMacroStorage.cls

@@ -0,0 +1,84 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ThisMacroStorage"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
+Public sreg As New ShapeRange
+
+Private Sub GlobalMacroStorage_SelectionChange()
+On Error GoTo ErrorHandler
+  Dim n As Long
+  Dim nr As NodeRange
+  Dim sh As Shape
+  
+  If ActiveSelection.Shapes.Count > 0 Then
+    n = 0
+    For Each sh In ActiveSelection.Shapes
+      If sh.Type = cdrCurveShape Then
+        Set nr = sh.Curve.Selection
+        n = n + nr.Count
+      End If
+    Next sh
+
+    If n > 2 Then
+        LinesForm.Caption = "Nodes: " & n
+    ElseIf ActiveSelection.Shapes.Count > 1 Then
+       LinesForm.Caption = "Select: " & ActiveSelection.Shapes.Count
+      End If
+  Else
+      LinesForm.Caption = "LinesForm By Lanya"
+  End If
+
+  If ActiveSelection.Shapes.Count = 1 Then
+    '// 检测Ctrl:Alt:Shift键状态 17-18-16
+    
+    If scankey() = 17 Then
+      If sreg.Exists(ActiveShape) Then sreg.Remove sreg.IndexOf(ActiveShape)
+      sreg.Add ActiveShape
+      LinesForm.Caption = "ActiveShape add SREG! Count:" & sreg.Count
+    End If
+    
+    If scankey() = 18 Then
+      sreg.RemoveAll
+      LinesForm.Caption = "SREG is Removed!"
+    End If
+    
+    If scankey() = 16 Then
+      sreg.CreateSelection
+    End If
+  
+  End If
+
+  If ActiveSelection.Shapes.Count > 2 And AutoDistribute_Key Then
+    Dim sr As ShapeRange
+    Set sr = ActiveSelectionRange
+    sr.Sort "@shape1.left<@shape2.left"
+    If first_StaticID <> sr.FirstShape.StaticID Then
+      Average_Distance
+    End If
+  End If
+ErrorHandler:
+
+End Sub
+
+Private Function scankey() As Long
+    Dim ctrlPressed As Boolean
+    Dim shiftPressed As Boolean
+    Dim altPressed As Boolean
+    
+    
+    ' 检测Ctrl键的状态  ' 检测Shift键的状态   ' 检测Alt键的状态
+    ctrlPressed = GetAsyncKeyState(17) And &H8000
+    shiftPressed = GetAsyncKeyState(16) And &H8000
+    altPressed = GetAsyncKeyState(18) And &H8000
+    
+    scankey = 0
+    If altPressed Then scankey = 18
+    If shiftPressed Then scankey = 16
+    If ctrlPressed Then scankey = 17
+End Function

MirrorParalleHorizon.bas

@@ -1,142 +1,142 @@
-Attribute VB_Name = "MirrorParalleHorizon"
-'// 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
-'// 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
-'// VB中用atn(), 返回值是弧度，需要 乘以 PI /180
-Private Function lineangle(x1, y1, x2, y2) As Double
-    pi = 4 * VBA.Atn(1)    '// 计算圆周率
-    If x2 = x1 Then
-      lineangle = 90: Exit Function
-    End If
-    lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
-  End Function
-  
-  '// 角度转平
-  Public Function Angle_to_Horizon()
-    On Error GoTo ErrorHandler
-    API.BeginOpt
-    Set sr = ActiveSelectionRange
-    Set nr = sr.LastShape.DisplayCurve.Nodes.All
-  
-    If nr.Count = 2 Then
-      x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
-      x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
-      a = lineangle(x1, y1, x2, y2): sr.Rotate -a
-      sr.LastShape.Delete   '// 删除参考线
-    End If
-ErrorHandler:
-    API.EndOpt
-  End Function
-
-'// 自动旋转角度
-Public Function Auto_Rotation_Angle()
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  
-'  ActiveDocument.ReferencePoint = cdrCenter
-  Set sr = ActiveSelectionRange
-  Set nr = sr.LastShape.DisplayCurve.Nodes.All
-
-  If nr.Count = 2 Then
-    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
-    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
-    a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
-    sr.LastShape.Delete   '// 删除参考线
-  End If
-ErrorHandler:
-  API.EndOpt
-End Function
-
-'// 交换对象
-Public Function Exchange_Object()
-  Set sr = ActiveSelectionRange
-  If sr.Count = 2 Then
-    x = sr.LastShape.CenterX: y = sr.LastShape.CenterY
-    sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
-    sr.FirstShape.CenterX = x: sr.FirstShape.CenterY = y
-  End If
-End Function
-
-'// 标记镜像参考线
-Public Function Set_Guides_Name()
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  Dim sr As ShapeRange, s As Shape
-  Set sr = ActiveSelectionRange
-  
-  For Each s In sr
-    s.name = "MirrorGuides"
-  Next s
-
-'// 感谢李总捐赠，定置透明度70%
-  With ActiveSelection.Transparency
-    .ApplyUniformTransparency 70
- '   .AppliedTo = cdrApplyToFillAndOutline
- '   .MergeMode = cdrMergeNormal
-  End With
-  
-ErrorHandler:
-  API.EndOpt
-End Function
-
-'// 参考线镜像
-Public Function Mirror_ByGuide()
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  Dim sr As ShapeRange, gds As ShapeRange
-  Set sr = ActiveSelectionRange
-  Set gds = sr.Shapes.FindShapes(Query:="@name ='MirrorGuides'")
-  
-  If gds.Count > 0 Then
- '//   sr.RemoveRange gds
-    Set nr = gds(1).DisplayCurve.Nodes.All
-  Else
-    Set nr = sr.LastShape.DisplayCurve.Nodes.All
- '//   sr.Remove sr.Count
-  End If
-  
-  If nr.Count >= 2 Then
-    byshape = False
-    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
-    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
-    a = lineangle(x1, y1, x2, y2)  '// 参考线和水平的夹角 a
-    
-    ang = 90 - a    '// 镜像的旋转角度
-   Set s = sr.Group
-      With s
-        Set s_copy = .Duplicate   '// 复制物件保留，然后按 x1,y1 点 旋转
-        
-        .RotationCenterX = x1
-        .RotationCenterY = y1
-        .Rotate ang
-        If Not byshape Then
-            lx = .LeftX
-            .Stretch -1#, 1#    '// 通过拉伸完成镜像
-            .LeftX = lx
-            .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
-            .RotationCenterX = x1     '// 之前因为镜像，旋转中心点反了，重置回来
-            .RotationCenterY = y1
-            .Rotate -ang
-        End If
-        .RotationCenterX = .CenterX   '// 重置回旋转中心点为物件中心
-        .RotationCenterY = .CenterY
-        .Ungroup
-        s_copy.Ungroup
-      End With
-  End If
-
-ErrorHandler:
-  API.EndOpt
-End Function
-
-'// 物件建立平行线
-Public Function Create_Parallel_Lines(space As Double)
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  
-  Dim sr As ShapeRange
-  Set sr = ActiveSelectionRange
-  sr.CreateParallelCurves 1, space
-
-ErrorHandler:
-  API.EndOpt
-End Function
+Attribute VB_Name = "MirrorParalleHorizon"
+'// 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
+'// 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
+'// VB中用atn(), 返回值是弧度，需要 乘以 PI /180
+Private Function lineangle(x1, y1, x2, y2) As Double
+    pi = 4 * VBA.Atn(1)    '// 计算圆周率
+    If x2 = x1 Then
+      lineangle = 90: Exit Function
+    End If
+    lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
+  End Function
+  
+  '// 角度转平
+  Public Function Angle_to_Horizon()
+    On Error GoTo ErrorHandler
+    API.BeginOpt
+    Set sr = ActiveSelectionRange
+    Set nr = sr.LastShape.DisplayCurve.Nodes.All
+  
+    If nr.Count = 2 Then
+      x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+      x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+      a = lineangle(x1, y1, x2, y2): sr.Rotate -a
+      sr.LastShape.Delete   '// 删除参考线
+    End If
+ErrorHandler:
+    API.EndOpt
+  End Function
+
+'// 自动旋转角度
+Public Function Auto_Rotation_Angle()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+'  ActiveDocument.ReferencePoint = cdrCenter
+  Set sr = ActiveSelectionRange
+  Set nr = sr.LastShape.DisplayCurve.Nodes.All
+
+  If nr.Count = 2 Then
+    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+    a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
+    sr.LastShape.Delete   '// 删除参考线
+  End If
+ErrorHandler:
+  API.EndOpt
+End Function
+
+'// 交换对象
+Public Function Exchange_Object()
+  Set sr = ActiveSelectionRange
+  If sr.Count = 2 Then
+    x = sr.LastShape.CenterX: y = sr.LastShape.CenterY
+    sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
+    sr.FirstShape.CenterX = x: sr.FirstShape.CenterY = y
+  End If
+End Function
+
+'// 标记镜像参考线
+Public Function Set_Guides_Name()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  Dim sr As ShapeRange, s As Shape
+  Set sr = ActiveSelectionRange
+  
+  For Each s In sr
+    s.name = "MirrorGuides"
+  Next s
+
+'// 感谢李总捐赠，定置透明度70%
+  With ActiveSelection.Transparency
+    .ApplyUniformTransparency 70
+ '   .AppliedTo = cdrApplyToFillAndOutline
+ '   .MergeMode = cdrMergeNormal
+  End With
+  
+ErrorHandler:
+  API.EndOpt
+End Function
+
+'// 参考线镜像
+Public Function Mirror_ByGuide()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  Dim sr As ShapeRange, gds As ShapeRange
+  Set sr = ActiveSelectionRange
+  Set gds = sr.Shapes.FindShapes(Query:="@name ='MirrorGuides'")
+  
+  If gds.Count > 0 Then
+ '//   sr.RemoveRange gds
+    Set nr = gds(1).DisplayCurve.Nodes.All
+  Else
+    Set nr = sr.LastShape.DisplayCurve.Nodes.All
+ '//   sr.Remove sr.Count
+  End If
+  
+  If nr.Count >= 2 Then
+    byshape = False
+    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+    a = lineangle(x1, y1, x2, y2)  '// 参考线和水平的夹角 a
+    
+    ang = 90 - a    '// 镜像的旋转角度
+   Set s = sr.Group
+      With s
+        Set s_copy = .Duplicate   '// 复制物件保留，然后按 x1,y1 点 旋转
+        
+        .RotationCenterX = x1
+        .RotationCenterY = y1
+        .Rotate ang
+        If Not byshape Then
+            lx = .LeftX
+            .Stretch -1#, 1#    '// 通过拉伸完成镜像
+            .LeftX = lx
+            .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
+            .RotationCenterX = x1     '// 之前因为镜像，旋转中心点反了，重置回来
+            .RotationCenterY = y1
+            .Rotate -ang
+        End If
+        .RotationCenterX = .CenterX   '// 重置回旋转中心点为物件中心
+        .RotationCenterY = .CenterY
+        .Ungroup
+        s_copy.Ungroup
+      End With
+  End If
+
+ErrorHandler:
+  API.EndOpt
+End Function
+
+'// 物件建立平行线
+Public Function Create_Parallel_Lines(space As Double)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  sr.CreateParallelCurves 1, space
+
+ErrorHandler:
+  API.EndOpt
+End Function

RotateMoveDuplicate.bas

@@ -1,42 +1,42 @@
-Attribute VB_Name = "RotateMoveDuplicate"
-Public Function move_shapes(x As Double, y As Double)
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  
-  Dim sr As ShapeRange     '// 使用 ShapeRange 可以多个物件一起操作
-  Set sr = ActiveSelectionRange   '// 选择物件队列使用 ActiveSelectionRange
-  sr.Move x, y             '// 默认单位是 英寸 所以移动太远了
-  
-ErrorHandler:
-  API.EndOpt
-End Function
-
-Public Function Duplicate_shapes(x As Double, y As Double)
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  
-  Dim sr As ShapeRange
-  Dim sr_copy As ShapeRange
-  Set sr = ActiveSelectionRange
-  Set sr_copy = sr.Duplicate(x, y)    '// Duplicate 是再制，如果前面有 = 赋值，就要加上 (x,y)
-  sr_copy.CreateSelection
-
-ErrorHandler:
-  API.EndOpt
-End Function
-
-'// 批量旋转角度
-Public Function Shapes_Rotate(angle As Double)
-  On Error GoTo ErrorHandler
-  API.BeginOpt
-  
-  ActiveDocument.ReferencePoint = cdrCenter
-  Dim sr As ShapeRange
-  Set sr = ActiveSelectionRange
-  For Each s In sr
-    s.Rotate angle
-  Next
-  
-ErrorHandler:
-  API.EndOpt
-End Function
+Attribute VB_Name = "RotateMoveDuplicate"
+Public Function move_shapes(x As Double, y As Double)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  Dim sr As ShapeRange     '// 使用 ShapeRange 可以多个物件一起操作
+  Set sr = ActiveSelectionRange   '// 选择物件队列使用 ActiveSelectionRange
+  sr.Move x, y             '// 默认单位是 英寸 所以移动太远了
+  
+ErrorHandler:
+  API.EndOpt
+End Function
+
+Public Function Duplicate_shapes(x As Double, y As Double)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  Dim sr As ShapeRange
+  Dim sr_copy As ShapeRange
+  Set sr = ActiveSelectionRange
+  Set sr_copy = sr.Duplicate(x, y)    '// Duplicate 是再制，如果前面有 = 赋值，就要加上 (x,y)
+  sr_copy.CreateSelection
+
+ErrorHandler:
+  API.EndOpt
+End Function
+
+'// 批量旋转角度
+Public Function Shapes_Rotate(angle As Double)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  ActiveDocument.ReferencePoint = cdrCenter
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  For Each s In sr
+    s.Rotate angle
+  Next
+  
+ErrorHandler:
+  API.EndOpt
+End Function

Tools.bas

@@ -1,56 +1,56 @@
-Attribute VB_Name = "Tools"
-'// This is free and unencumbered software released into the public domain.
-'// For more information, please refer to  https://github.com/hongwenjun
-
-'// 简易火车排列
-Public Function Simple_Train_Arrangement(Space_Width As Double)
-  API.BeginOpt
-  Dim ssr As ShapeRange, s As Shape
-  Dim cnt As Integer
-  Set ssr = ActiveSelectionRange
-  cnt = 1
-
-#If VBA7 Then
-'  ssr.sort " @shape1.top>@shape2.top"
-  ssr.Sort " @shape1.left<@shape2.left"
-#Else
-' X4 不支持 ShapeRange.sort  使用 lyvba32.dll 算法库排序   2023.07.08
-  Set ssr = X4_Sort_ShapeRange(ssr, stlx)
-#End If
-
-  ActiveDocument.ReferencePoint = cdrTopLeft
-  For Each s In ssr
-    '// 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
-    '// 改成顶对齐 2022-08-10
-    ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).topY
-    cnt = cnt + 1
-  Next s
-
-  API.EndOpt
-End Function
-
-'// 简易阶梯排列
-Public Function Simple_Ladder_Arrangement(Space_Width As Double)
-  API.BeginOpt
-  Dim ssr As ShapeRange, s As Shape
-  Dim cnt As Integer
-  Set ssr = ActiveSelectionRange
-  cnt = 1
-
-#If VBA7 Then
-  ssr.Sort " @shape1.top>@shape2.top"
-#Else
-' X4 不支持 ShapeRange.sort  使用 lyvba32.dll 算法库排序   2023.07.08
-  Set ssr = X4_Sort_ShapeRange(ssr, stty).ReverseRange
-#End If
-
-
-  ActiveDocument.ReferencePoint = cdrTopLeft
-  For Each s In ssr
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - Space_Width
-    cnt = cnt + 1
-  Next s
-
-  API.EndOpt
-End Function
+Attribute VB_Name = "Tools"
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+'// 简易火车排列
+Public Function Simple_Train_Arrangement(Space_Width As Double)
+  API.BeginOpt
+  Dim ssr As ShapeRange, s As Shape
+  Dim cnt As Integer
+  Set ssr = ActiveSelectionRange
+  cnt = 1
+
+#If VBA7 Then
+'  ssr.sort " @shape1.top>@shape2.top"
+  ssr.Sort " @shape1.left<@shape2.left"
+#Else
+' X4 不支持 ShapeRange.sort  使用 lyvba32.dll 算法库排序   2023.07.08
+  Set ssr = X4_Sort_ShapeRange(ssr, stlx)
+#End If
+
+  ActiveDocument.ReferencePoint = cdrTopLeft
+  For Each s In ssr
+    '// 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
+    '// 改成顶对齐 2022-08-10
+    ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).TopY
+    cnt = cnt + 1
+  Next s
+
+  API.EndOpt
+End Function
+
+'// 简易阶梯排列
+Public Function Simple_Ladder_Arrangement(Space_Width As Double)
+  API.BeginOpt
+  Dim ssr As ShapeRange, s As Shape
+  Dim cnt As Integer
+  Set ssr = ActiveSelectionRange
+  cnt = 1
+
+#If VBA7 Then
+  ssr.Sort " @shape1.top>@shape2.top"
+#Else
+' X4 不支持 ShapeRange.sort  使用 lyvba32.dll 算法库排序   2023.07.08
+  Set ssr = X4_Sort_ShapeRange(ssr, stty).ReverseRange
+#End If
+
+
+  ActiveDocument.ReferencePoint = cdrTopLeft
+  For Each s In ssr
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - Space_Width
+    cnt = cnt + 1
+  Next s
+
+  API.EndOpt
+End Function

lines.bas

@@ -1,99 +1,99 @@
-Attribute VB_Name = "lines"
-'// This is free and unencumbered software released into the public domain.
-'// For more information, please refer to  https://github.com/hongwenjun
-
-Sub start()
-  LinesForm.Show 0
-End Sub
-
-Public Function Nodes_DrawLines()
-  Dim sr As ShapeRange, sr_tmp As New ShapeRange, sr_lines As New ShapeRange
-  Dim s As Shape, sh As Shape
-  Dim nr As NodeRange
-  Set sr = ActiveSelectionRange
-  If sr.Count = 0 Then Exit Function
-  
-  For Each sh In sr
-    Set nr = sh.Curve.Selection
-    If nr.Count > 0 Then
-      For Each n In nr
-        Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5)
-        sr_tmp.Add s
-      Next n
-    End If
-  Next sh
-  
-  '// 没有选择节点的情况，使用物件中心划线
-  If sr_tmp.Count < 2 And sr.Count > 1 Then
-    Set Line = DrawLine(sr(1), sr(2))
-    sr_lines.Add Line
-  End If
-
-#If VBA7 Then
-    sr_tmp.Sort "@shape1.left < @shape2.left"
-#Else
-    Set sr_tmp = X4_Sort_ShapeRange(sr_tmp, stlx)
-#End If
-
-  '// 使用 Count 遍历 shaperange 这种情况方便点
-  For i = 1 To sr_tmp.Count - 1
-    Set Line = DrawLine(sr_tmp(i), sr_tmp(i + 1))
-    sr_lines.Add Line
-  Next
-  
-  sr_tmp.Delete
-  sr_lines.CreateSelection
-End Function
-
-Public Function Draw_Multiple_Lines(hv As cdrAlignType)
-  Dim sr As ShapeRange, sr_lines As New ShapeRange
-  Set sr = ActiveSelectionRange
-  
-  If sr.Count < 2 Then Exit Function
-  
-#If VBA7 Then
-  If hv = cdrAlignVCenter Then
-    '// 从左到右排序
-    sr.Sort "@shape1.left < @shape2.left"
-  ElseIf hv = cdrAlignHCenter Then
-    '// 从上到下排序
-    sr.Sort "@shape1.top < @shape2.top"
-  End If
-#Else
-  '// X4_Sort_ShapeRange for CorelDRAW X4
-  If hv = cdrAlignVCenter Then
-    Set sr = X4_Sort_ShapeRange(sr, stlx)
-  ElseIf hv = cdrAlignHCenter Then
-    Set sr = X4_Sort_ShapeRange(sr, stty)
-  End If
- 
-#End If
-
-  For i = 1 To sr.Count - 1 Step 2
-    Set Line = DrawLine(sr(i), sr(i + 1))
-    sr_lines.Add Line
-  Next
- 
-  sr_lines.CreateSelection
-End Function
-
-Public Function FirtLineTool()
-  Dim sr As ShapeRange
-  Set sr = ActiveSelectionRange
-  If sr.Count > 1 Then
-    Set Line = DrawLine(sr(1), sr(2))
-  End If
-End Function
-
-Private Function DrawLine(ByVal s1 As Shape, ByVal s2 As Shape) As Shape
-'// 创建线段方法在图层上的指定位置创建由单个线段组成的曲线。
- Set DrawLine = ActiveLayer.CreateLineSegment(s1.CenterX, s1.CenterY, s2.CenterX, s2.CenterY)
-
-End Function
-
-Private Sub Test()
-  ActiveDocument.Unit = cdrMillimeter
-  Set Rect = ActiveLayer.CreateRectangle(0, 0, 30, 30)
-  Set ell = ActiveLayer.CreateEllipse2(50, 50, 10, 10)
-  Set Line = DrawLine(Rect, ell)
-End Sub
+Attribute VB_Name = "lines"
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+Sub start()
+  LinesForm.Show 0
+End Sub
+
+Public Function Nodes_DrawLines()
+  Dim sr As ShapeRange, sr_tmp As New ShapeRange, sr_lines As New ShapeRange
+  Dim s As Shape, sh As Shape
+  Dim nr As NodeRange
+  Set sr = ActiveSelectionRange
+  If sr.Count = 0 Then Exit Function
+  
+  For Each sh In sr
+    Set nr = sh.Curve.Selection
+    If nr.Count > 0 Then
+      For Each n In nr
+        Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5)
+        sr_tmp.Add s
+      Next n
+    End If
+  Next sh
+  
+  '// 没有选择节点的情况，使用物件中心划线
+  If sr_tmp.Count < 2 And sr.Count > 1 Then
+    Set Line = DrawLine(sr(1), sr(2))
+    sr_lines.Add Line
+  End If
+
+#If VBA7 Then
+    sr_tmp.Sort "@shape1.left < @shape2.left"
+#Else
+    Set sr_tmp = X4_Sort_ShapeRange(sr_tmp, stlx)
+#End If
+
+  '// 使用 Count 遍历 shaperange 这种情况方便点
+  For i = 1 To sr_tmp.Count - 1
+    Set Line = DrawLine(sr_tmp(i), sr_tmp(i + 1))
+    sr_lines.Add Line
+  Next
+  
+  sr_tmp.Delete
+  sr_lines.CreateSelection
+End Function
+
+Public Function Draw_Multiple_Lines(hv As cdrAlignType)
+  Dim sr As ShapeRange, sr_lines As New ShapeRange
+  Set sr = ActiveSelectionRange
+  
+  If sr.Count < 2 Then Exit Function
+  
+#If VBA7 Then
+  If hv = cdrAlignVCenter Then
+    '// 从左到右排序
+    sr.Sort "@shape1.left < @shape2.left"
+  ElseIf hv = cdrAlignHCenter Then
+    '// 从上到下排序
+    sr.Sort "@shape1.top < @shape2.top"
+  End If
+#Else
+  '// X4_Sort_ShapeRange for CorelDRAW X4
+  If hv = cdrAlignVCenter Then
+    Set sr = X4_Sort_ShapeRange(sr, stlx)
+  ElseIf hv = cdrAlignHCenter Then
+    Set sr = X4_Sort_ShapeRange(sr, stty)
+  End If
+ 
+#End If
+
+  For i = 1 To sr.Count - 1 Step 2
+    Set Line = DrawLine(sr(i), sr(i + 1))
+    sr_lines.Add Line
+  Next
+ 
+  sr_lines.CreateSelection
+End Function
+
+Public Function FirtLineTool()
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  If sr.Count > 1 Then
+    Set Line = DrawLine(sr(1), sr(2))
+  End If
+End Function
+
+Private Function DrawLine(ByVal s1 As Shape, ByVal s2 As Shape) As Shape
+'// 创建线段方法在图层上的指定位置创建由单个线段组成的曲线。
+ Set DrawLine = ActiveLayer.CreateLineSegment(s1.CenterX, s1.CenterY, s2.CenterX, s2.CenterY)
+
+End Function
+
+Private Sub Test()
+  ActiveDocument.Unit = cdrMillimeter
+  Set Rect = ActiveLayer.CreateRectangle(0, 0, 30, 30)
+  Set ell = ActiveLayer.CreateEllipse2(50, 50, 10, 10)
+  Set Line = DrawLine(Rect, ell)
+End Sub