CorelDRAW VBA 插件和源码

ALGO.bas

@@ -0,0 +1,101 @@
+Attribute VB_Name = "ALGO"
+'// 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

@@ -0,0 +1,261 @@
+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
+
+'// Attribute VB_Name = "CorelVBA工具窗口启动"   CorelVBA Tool Window Launches  2023.6.11
+
+'// 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
+
+

Box.bas

@@ -0,0 +1,135 @@
+Attribute VB_Name = "box"
+Public Function Simple_box_three()
+  ActiveDocument.Unit = cdrMillimeter
+  Dim sr As New ShapeRange, wing As New ShapeRange
+  Dim sh As Shape
+  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
+  
+  '// 绘制Box 圆角矩形插口
+  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 50, 50)
+  top_RoundRect.Move l1x, h + w
+  Set bottom_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 0, 0, 50, 50)
+  bottom_RoundRect.Move l3x, -w - b
+    
+  '// 绘制box 四个翅膀
+  Set sh = DrawWing(ActiveLayer.CreateRectangle(0, 0, 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).Flip cdrFlipVertical
+  wing(4).Rotate 180
+
+  '// 添加到物件组，设置轮廓色 C100
+  sr.Add mainRect: sr.Add topRect: sr.Add bottomRect
+  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)
+  
+  '// 盒子box 群组
+  sr.Add sl1: sr.Add sl2: sr.Add sl3: sr.Add sl4
+  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 DrawWing(s As Shape) As Shape
+    Dim sp As SubPath, crv As Curve
+    Dim x As Double, y As Double
+    x = s.SizeWidth: y = s.SizeHeight
+    s.Delete
+    
+    '// 绘制 Box 翅膀 Wing
+    Set crv = Application.CreateCurve(ActiveDocument)
+    Set sp = crv.CreateSubPath(0, 0)
+    sp.AppendLineSegment 0, 4
+    sp.AppendLineSegment 2, 6
+    sp.AppendLineSegment 4, y - 2.5
+    sp.AppendCurveSegment2 6.5, y, 4.1, y - 1.25, 5.1, 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
+
+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
+      ' // 先上下再左右排序
+      sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+      
+      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/LinesForm.frm

@@ -0,0 +1,64 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} LinesForm 
+   Caption         =   "LinesForm"
+   ClientHeight    =   855
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   4725
+   OleObjectBlob   =   "LinesForm.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "LinesForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private Sub MyPen_Click()
+  lines.Nodes_DrawLines
+End Sub
+
+
+'// 左键右键Ctrl三键控制
+Private Sub PenDrawLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  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
+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_Click()
+  box.Simple_box_three
+End Sub
+
+Private Sub Cmd_3D_Click()
+  box.Simple_3Deffect
+End Sub

README.md

@@ -1,2 +1,8 @@
 # vbabox
+
+![](https://github.com/hongwenjun/vbabox/blob/main/img/vbabox.webp)
+
 CorelDRAW VBA 插件 简易的长宽高盒子插件和源码和步骤原理
+
+https://www.bilibili.com/video/BV1MF411f7qu/
+

Tools.bas

@@ -0,0 +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

lines.bas

@@ -0,0 +1,99 @@
+Attribute VB_Name = "lines"
+'// 代码写到这里吧，视频结束
+Sub start()
+  LinesForm.Show 0
+End Sub
+
+Public Function Nodes_DrawLines()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  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
+  
+  sr_tmp.Sort "@shape1.left < @shape2.left"
+  
+  '// 使用 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
+ErrorHandler:
+  API.EndOpt
+End Function
+
+
+Public Function Draw_Multiple_Lines(hv As cdrAlignType)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  Dim sr As ShapeRange, sr_lines As New ShapeRange
+  Set sr = ActiveSelectionRange
+  
+  If sr.Count < 2 Then Exit Function
+  
+  If hv = cdrAlignVCenter Then
+    '// 从左到右排序
+    sr.Sort "@shape1.left < @shape2.left"
+  ElseIf hv = cdrAlignHCenter Then
+    '// 从上到下排序
+    sr.Sort "@shape1.top < @shape2.top"
+  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
+ErrorHandler:
+  API.EndOpt
+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
+
+
+
+
+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