更新批量旋转移动排列间距和自动间距工具

ALGO.bas

@@ -1,9 +1,12 @@
 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
+'// 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, _
@@ -70,7 +73,7 @@ Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By
     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.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

API.bas

@@ -2,8 +2,6 @@ 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

AverageDistance.bas

@@ -0,0 +1,38 @@
+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,4 +1,7 @@
 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
@@ -42,7 +45,6 @@ Public Function Simple_box_five(Optional ByVal l As Double, Optional ByVal w As
   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
@@ -98,7 +100,7 @@ Private Function DrawBottomWing(ByVal l As Double, ByVal w As Double, ByVal b As
   
   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
+  sr(2).topY = 0: sr(3).topY = 0
   Set DrawBottomWing = sr
   
 End Function
@@ -109,7 +111,6 @@ Public Function Simple_box_four(Optional ByVal l As Double, Optional ByVal w As
   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)
@@ -156,7 +157,6 @@ Public Function Simple_box_four(Optional ByVal l As Double, Optional ByVal w As
   sr.Add SealLine: sr.Add SealLine2
   sr.CreateSelection: sr.Group
   
-  
 End Function
 
 Public Function input_box_lwh() As Variant
@@ -260,17 +260,17 @@ 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
+    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 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
     
@@ -280,14 +280,14 @@ 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
+    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 0, y
+    sp.AppendLineSegment x, y - 5
     sp.AppendLineSegment x, 5
 
     sp.Closed = True
@@ -334,22 +334,25 @@ End Function
 
 
 Public Function Simple_3Deffect()
-    Dim sr As ShapeRange    ' 定义物件范围
-    Set sr = ActiveSelectionRange   ' 选择3个物件
+  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#
+  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#
       
-    End If
+    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

@@ -1,10 +1,10 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} LinesForm 
    Caption         =   "LinesForm"
-   ClientHeight    =   855
+   ClientHeight    =   1620
    ClientLeft      =   45
    ClientTop       =   390
-   ClientWidth     =   4725
+   ClientWidth     =   4680
    OleObjectBlob   =   "LinesForm.frx":0000
    StartUpPosition =   1  '所有者中心
 End
@@ -13,13 +13,51 @@ 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)
+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
     
@@ -28,11 +66,13 @@ Private Sub PenDrawLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
   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)
+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
@@ -43,7 +83,7 @@ Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
 End Sub
 
 '''////  傻瓜阶梯排列  ////'''
-Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+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
@@ -54,7 +94,7 @@ Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
 End Sub
 
 
-Private Sub MakeBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+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
   
@@ -78,3 +118,44 @@ 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 Average_Distance_BT_Click()
+  Average_Distance
+End Sub
+
+Private Sub chkAutoDistribute_Click()
+  AutoDistribute_Key = chkAutoDistribute.Value
+End Sub

RotateMoveDuplicate.bas

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

ThisMacroStorage.cls

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

Tools.bas

@@ -23,7 +23,7 @@ Public Function Simple_Train_Arrangement(Space_Width As Double)
     '// µ×¶ÔÆë 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
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).topY
     cnt = cnt + 1
   Next s
 

lines.bas

@@ -1,12 +1,12 @@
 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()
-  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
@@ -28,9 +28,13 @@ Public Function Nodes_DrawLines()
     Set Line = DrawLine(sr(1), sr(2))
     sr_lines.Add Line
   End If
-  
-  sr_tmp.Sort "@shape1.left < @shape2.left"
-  
+
+#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))
@@ -39,19 +43,15 @@ Public Function Nodes_DrawLines()
   
   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 VBA7 Then
   If hv = cdrAlignVCenter Then
     '// 从左到右排序
     sr.Sort "@shape1.left < @shape2.left"
@@ -59,18 +59,24 @@ Public Function Draw_Multiple_Lines(hv As cdrAlignType)
     '// 从上到下排序
     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
-ErrorHandler:
-  API.EndOpt
 End Function
 
-
 Public Function FirtLineTool()
   Dim sr As ShapeRange
   Set sr = ActiveSelectionRange
@@ -85,15 +91,9 @@ Private Function DrawLine(ByVal s1 As Shape, ByVal s2 As Shape) As Shape
 
 End Function
 
-
-
-
-Sub Test()
+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)
-
+  Set Rect = ActiveLayer.CreateRectangle(0, 0, 30, 30)
+  Set ell = ActiveLayer.CreateEllipse2(50, 50, 10, 10)
+  Set Line = DrawLine(Rect, ell)
 End Sub