2022.12.09更新,增加安全辅助线和批量多页居中功能

UI/CQL_FIND_UI.bas

@@ -15,17 +15,18 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
+
 #If VBA7 Then
-    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
-    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     
 #Else
-    Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
-    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 #End If
@@ -41,16 +42,16 @@ End Sub
 
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
-  Dim hwnd As Long
+  Dim hWnd As Long
   
-  hwnd = FindWindow("ThunderDFrame", Me.Caption)
+  hWnd = FindWindow("ThunderDFrame", Me.Caption)
 
-  IStyle = GetWindowLong(hwnd, GWL_STYLE)
+  IStyle = GetWindowLong(hWnd, GWL_STYLE)
   IStyle = IStyle And Not WS_CAPTION
-  SetWindowLong hwnd, GWL_STYLE, IStyle
-  DrawMenuBar hwnd
-  IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
-  SetWindowLong hwnd, GWL_EXSTYLE, IStyle
+  SetWindowLong hWnd, GWL_STYLE, IStyle
+  DrawMenuBar hWnd
+  IStyle = GetWindowLong(hWnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong hWnd, GWL_EXSTYLE, IStyle
 
   With Me
   '  .StartUpPosition = 0
@@ -62,41 +63,41 @@ Private Sub UserForm_Initialize()
   
 End Sub
 
-Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-    mx = X
+    mx = x
     my = Y
 
   End If
 End Sub
 
-Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-  Debug.Print X, Y
-    Me.Left = Me.Left - mx + X
+  Debug.Print x, Y
+    Me.Left = Me.Left - mx + x
     Me.Top = Me.Top - my + Y
   End If
 End Sub
 
-Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   Dim pos_x As Variant
   Dim pos_y As Variant
   pos_x = Array(307, 27)
   pos_y = Array(64, 126, 188, 200)
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
     Call CQLSameUniformColor
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
     Call CQLSameOutlineColor
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
     Call CQLSameSize
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
     CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
   
   '// 预置颜色轮廓选择
-  If Abs(X - 178) < 30 And Abs(Y - 118) < 30 Then
-    Debug.Print "选择图标: " & X & "  , " & Y
+  If Abs(x - 178) < 30 And Abs(Y - 118) < 30 Then
+    Debug.Print "选择图标: " & x & "  , " & Y
     CQL查找相同.CQLline_CM100
   End If
   
@@ -118,7 +119,7 @@ Private Sub CQLSameSize()
     Dim Shift As Long
     Dim box As Boolean
     box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
-    If Not b Then
+    If Not B Then
       ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
       Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
       sh.Shapes.FindShapes(Query:="@width = {" & s.SizeWidth & " mm} and @height ={" & s.SizeHeight & "mm}").CreateSelection
@@ -138,7 +139,7 @@ Private Sub CQLSameOutlineColor()
   ' 查找对象
   r = colr.RGBRed
   G = colr.RGBGreen
-  b = colr.RGBBlue
+  B = colr.RGBBlue
   
   If OptBt.value = True Then
     ActiveDocument.ClearSelection
@@ -149,13 +150,13 @@ Private Sub CQLSameOutlineColor()
     Dim Shift As Long
     Dim box As Boolean
     box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
-    If Not b Then
+    If Not B Then
       ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
       Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
-      sh.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
+      sh.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & B & "']").CreateSelection
     End If
   Else
-    ActivePage.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
+    ActivePage.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & B & "']").CreateSelection
   End If
   
   Exit Sub
@@ -174,7 +175,7 @@ Private Sub CQLSameUniformColor()
   ' 查找对象
   r = colr.RGBRed
   G = colr.RGBGreen
-  b = colr.RGBBlue
+  B = colr.RGBBlue
   
   If OptBt.value = True Then
     ActiveDocument.ClearSelection
@@ -185,13 +186,13 @@ Private Sub CQLSameUniformColor()
     Dim Shift As Long
     Dim box As Boolean
     box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
-    If Not b Then
+    If Not B Then
       ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
       Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
-      sh.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
+      sh.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & B & "']").CreateSelection
     End If
   Else
-    ActivePage.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
+    ActivePage.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & B & "']").CreateSelection
   End If
   Exit Sub
 err:

UI/CorelVBA.bas

@@ -16,19 +16,20 @@ Attribute VB_Exposed = False
 
 
 
+
 #If VBA7 Then
-    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
-    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
-    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     
 #Else
-  Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
-    Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
-    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 #End If
@@ -51,16 +52,16 @@ End Sub
 
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
-  Dim hwnd As Long
+  Dim hWnd As Long
   
-  hwnd = FindWindow("ThunderDFrame", Me.Caption)
+  hWnd = FindWindow("ThunderDFrame", Me.Caption)
 
-  IStyle = GetWindowLong(hwnd, GWL_STYLE)
+  IStyle = GetWindowLong(hWnd, GWL_STYLE)
   IStyle = IStyle And Not WS_CAPTION
-  SetWindowLong hwnd, GWL_STYLE, IStyle
-  DrawMenuBar hwnd
-  IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
-  SetWindowLong hwnd, GWL_EXSTYLE, IStyle
+  SetWindowLong hWnd, GWL_STYLE, IStyle
+  DrawMenuBar hWnd
+  IStyle = GetWindowLong(hWnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong hWnd, GWL_EXSTYLE, IStyle
 
   With Me
   '  .StartUpPosition = 0
@@ -76,16 +77,16 @@ Private Sub UserForm_Initialize()
   End If
 End Sub
 
-Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-    mx = X
+    mx = x
     my = Y
   End If
 End Sub
 
-Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-    Me.Left = Me.Left - mx + X
+    Me.Left = Me.Left - mx + x
     Me.Top = Me.Top - my + Y
   End If
 End Sub
@@ -94,7 +95,7 @@ Private Sub About_Cmd_Click()
   MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
 End Sub
 
-Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
 
   ' 定义图标坐标pos
   Dim pos_x As Variant
@@ -102,43 +103,43 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   pos_x = Array(32, 110, 186, 265, 345)
   pos_y = Array(50, 135, 215)
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
     物件角线
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(Y - pos_y(0)) < 30 Then
     绘制矩形
-  ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(2)) < 30 And Abs(Y - pos_y(0)) < 30 Then
     角线爬虫
-  ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(3)) < 30 And Abs(Y - pos_y(0)) < 30 Then
     矩形拼版
-  ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(4)) < 30 And Abs(Y - pos_y(0)) < 30 Then
     拼版角线
   End If
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
     Tools.居中页面
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(Y - pos_y(1)) < 30 Then
     拼版标记
-  ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(2)) < 30 And Abs(Y - pos_y(1)) < 30 Then
     智能群组
-  ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(3)) < 30 And Abs(Y - pos_y(1)) < 30 Then
     CQL选择
-  ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(4)) < 30 And Abs(Y - pos_y(1)) < 30 Then
     批量替换
   End If
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
     Tools.尺寸取整
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(Y - pos_y(2)) < 30 Then
     Tools.TextShape_ConvertToCurves
-  ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(2)) < 30 And Abs(Y - pos_y(2)) < 30 Then
     Dim h As Long, r As Long
     mypath = Path & "GMS\262235.xyz\"
     App = mypath & "GuiAdobeThumbnail.exe"
     
     h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
-    i = ShellExecute(h, "", App, "", mypath, 1)
+    I = ShellExecute(h, "", App, "", mypath, 1)
 
-  ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(3)) < 30 And Abs(Y - pos_y(2)) < 30 Then
     If switch Then
       switch = Not switch
       Tools.傻瓜火车排列 0#
@@ -147,12 +148,12 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
       Tools.傻瓜阶梯排列 0#
     End If
     
-  ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(4)) < 30 And Abs(Y - pos_y(2)) < 30 Then
     学习CorelVBA实验室
   End If
 
   
-  If Abs(X - 210) < 30 And Abs(Y - 261) < 8 Then
+  If Abs(x - 210) < 30 And Abs(Y - 261) < 8 Then
     WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
 
@@ -207,5 +208,5 @@ End Sub
 Private Sub 学习CorelVBA实验室()
   CorelVBA.Hide
   ' 调用语句
-  i = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
+  I = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
 End Sub

UI/Replace_UI.bas

@@ -15,17 +15,18 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
+
 #If VBA7 Then
-    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
-    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     
 #Else
-    Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
-    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 #End If
@@ -41,16 +42,16 @@ End Sub
 
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
-  Dim hwnd As Long
+  Dim hWnd As Long
   
-  hwnd = FindWindow("ThunderDFrame", Me.Caption)
+  hWnd = FindWindow("ThunderDFrame", Me.Caption)
 
-  IStyle = GetWindowLong(hwnd, GWL_STYLE)
+  IStyle = GetWindowLong(hWnd, GWL_STYLE)
   IStyle = IStyle And Not WS_CAPTION
-  SetWindowLong hwnd, GWL_STYLE, IStyle
-  DrawMenuBar hwnd
-  IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
-  SetWindowLong hwnd, GWL_EXSTYLE, IStyle
+  SetWindowLong hWnd, GWL_STYLE, IStyle
+  DrawMenuBar hWnd
+  IStyle = GetWindowLong(hWnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong hWnd, GWL_EXSTYLE, IStyle
   
   With Me
   '  .StartUpPosition = 0
@@ -62,34 +63,34 @@ Private Sub UserForm_Initialize()
   
 End Sub
 
-Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-    mx = X
+    mx = x
     my = Y
   End If
 End Sub
 
-Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-    Me.Left = Me.Left - mx + X
+    Me.Left = Me.Left - mx + x
     Me.Top = Me.Top - my + Y
   End If
 End Sub
 
 
-Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   Dim pos_x As Variant
   Dim pos_y As Variant
   pos_x = Array(307, 27)
   pos_y = Array(64, 126, 188, 200)
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
     Call copy_shape_replace
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
     Call copy_shape_replace_resize
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
     Call image_replace
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
     CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
   
@@ -104,7 +105,7 @@ Private Sub image_replace()
   image_path = API.GetClipBoardString
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, Y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -116,11 +117,11 @@ Private Sub image_replace()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
+    sh.GetPosition x, Y
+    sc.SetPosition x, Y
     
-    sh.GetSize X, Y
-    sc.SetSize X, Y
+    sh.GetSize x, Y
+    sc.SetSize x, Y
     sh.Delete
     
   Next sh
@@ -142,7 +143,7 @@ Private Sub copy_shape_replace_resize()
 
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, Y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -152,11 +153,11 @@ Private Sub copy_shape_replace_resize()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
+    sh.GetPosition x, Y
+    sc.SetPosition x, Y
     
-    sh.GetSize X, Y
-    sc.SetSize X, Y
+    sh.GetSize x, Y
+    sc.SetSize x, Y
     sh.Delete
     
   Next sh
@@ -179,7 +180,7 @@ Private Sub copy_shape_replace()
 
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, Y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -189,8 +190,8 @@ Private Sub copy_shape_replace()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
+    sh.GetPosition x, Y
+    sc.SetPosition x, Y
     sh.Delete
   Next sh
 

UI/Toolbar.bas

@@ -1,10 +1,10 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Toolbar 
    Caption         =   "Toolbar"
-   ClientHeight    =   3960
+   ClientHeight    =   4230
    ClientLeft      =   45
    ClientTop       =   330
-   ClientWidth     =   6750
+   ClientWidth     =   6780
    OleObjectBlob   =   "Toolbar.frx":0000
 End
 Attribute VB_Name = "Toolbar"
@@ -13,47 +13,71 @@ Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 #If VBA7 Then
-    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
-    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
-    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
     
 #Else
-    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
-    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
-    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
-    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
     Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
 #End If
 Private Const GWL_STYLE As Long = (-16)
 Private Const GWL_EXSTYLE = (-20)
 Private Const WS_CAPTION As Long = &HC00000
 Private Const WS_EX_DLGMODALFRAME = &H1&
 
+'Constants for transparency
+Private Const WS_EX_LAYERED = &H80000
+Private Const LWA_COLORKEY = &H1                  'Chroma key for fading a certain color on your Form
+Private Const LWA_ALPHA = &H2                     'Only needed if you want to fade the entire userform
+
 Public UIL_Key As Boolean
 Public pic1, pic2
 
+Private Sub MakeUserFormTransparent(frm As Object, Optional Color As Variant)
+  'set transparencies on userform
+  Dim formhandle As Long
+  Dim bytOpacity As Byte
+  
+  formhandle = FindWindow(vbNullString, Me.Caption)
+  If IsMissing(Color) Then Color = vbWhite 'default to vbwhite
+  bytOpacity = 100 ' variable keeping opacity setting
+  
+  SetWindowLong formhandle, GWL_EXSTYLE, GetWindowLong(formhandle, GWL_EXSTYLE) Or WS_EX_LAYERED
+  'The following line makes only a certain color transparent so the
+  ' background of the form and any object whose BackColor you've set to match
+  ' vbColor (default vbWhite) will be transparent.
+  Me.BackColor = Color
+  SetLayeredWindowAttributes formhandle, Color, bytOpacity, LWA_COLORKEY
+End Sub
 
 Private Sub Change_UI_Close_Voice_Click()
   Speak_Msg "修改UI图片更换界面  注册表关闭语音 详QQ群"
   MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
 End Sub
 
+
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
-  Dim hwnd As Long
+  Dim hWnd As Long
   
-  hwnd = FindWindow("ThunderDFrame", Me.Caption)
+  hWnd = FindWindow("ThunderDFrame", Me.Caption)
 
-  IStyle = GetWindowLong(hwnd, GWL_STYLE)
+  IStyle = GetWindowLong(hWnd, GWL_STYLE)
   IStyle = IStyle And Not WS_CAPTION
-  SetWindowLong hwnd, GWL_STYLE, IStyle
-  DrawMenuBar hwnd
-  IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
-  SetWindowLong hwnd, GWL_EXSTYLE, IStyle
+  SetWindowLong hWnd, GWL_STYLE, IStyle
+  DrawMenuBar hWnd
+  IStyle = GetWindowLong(hWnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong hWnd, GWL_EXSTYLE, IStyle
   
 With Me
   .StartUpPosition = 0
@@ -83,9 +107,15 @@ End With
     UIL_Key = True
   End If
 
+  ' 窗口透明, 最小化只显示一个图标
+  #If VBA7 Then
+    MakeUserFormTransparent Me, RGB(26, 22, 35)
+  #Else
+  ' CorelDRAW X4 / Windows7 自用关闭透明
+  #End If
 End Sub
 
-Private Sub UI_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub UI_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   UI.Visible = False
   If Y > 1 And Y < 16 And UIL_Key Then
     UI.Picture = pic2
@@ -97,9 +127,9 @@ Private Sub UI_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   ' Debug.Print X & " , " & Y
 End Sub
 
-Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If Button Then
-        mx = X
+        mx = x
         my = Y
     End If
     
@@ -109,39 +139,38 @@ Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,
 
 End Sub
 
-Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-    Me.Left = Me.Left - mx + X
+    Me.Left = Me.Left - mx + x
     Me.Top = Me.Top - my + Y
   End If
 End Sub
 
-Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
-  If Abs(X - 14) < 14 And Abs(Y - 14) < 14 And Button = 2 Then
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+  If Abs(x - 14) < 14 And Abs(Y - 14) < 14 And Button = 2 Then
     Me.Width = 336
     OPEN_UI_BIG.Left = 322
     UI.Visible = True
     LOGO.Visible = False
-    X_EXIT.Visible = False
     TOP_ALIGN_BT.Visible = False
     LEFT_ALIGN_BT.Visible = False
     Exit Sub
-  End If
-  
-  If Button Then
-      mx = X
+  ElseIf Shift = fmCtrlMask Then
+      mx = x
       my = Y
+  Else
+    Unload Me   ' Ctrl + 鼠标 关闭工具
   End If
 End Sub
 
-Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button Then
-    Me.Left = Me.Left - mx + X
+    Me.Left = Me.Left - mx + x
     Me.Top = Me.Top - my + Y
   End If
 End Sub
 
-Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   Dim c As New Color
   ' 定义图标坐标pos
   Dim pos_x As Variant
@@ -150,50 +179,55 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   pos_x = Array(14, 41, 67, 94, 121, 148, 174, 201, 228, 254, 281, 308, 334, 361, 388, 415, 441, 468, 495)
 
   '// 鼠标右键 扩展键按钮优先  收缩工具栏  标记范围框  居中页面 尺寸取整数  单色黑中线标记 扩展工具栏  排列工具  扩展工具栏收缩
-  If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  If Abs(x - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     Me.Width = 30
+    Me.Height = 30
     UI.Visible = False
     LOGO.Visible = True
-    X_EXIT.Visible = True
     Exit Sub
 
-  ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     Tools.居中页面
     Exit Sub
 
-  ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     Tools.Mark_Range_Box
     Exit Sub
 
-  ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     Tools.尺寸取整
     Exit Sub
   
-  ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     自动中线色阶条.Auto_ColorMark_K
     Exit Sub
   
   '//分分合合把几个功能按键合并到一起，定义到右键上
-  ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     Tools.分分合合
     Exit Sub
   
-  ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     智能群组和查找.智能群组 API.Create_Tolerance
     Exit Sub
   
-  ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     '// 右键扩展工具栏
     Me.Height = 30 + 45
     Exit Sub
   
-  ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+    '// 右键拆分线段
+    Tools.Split_Segment
+    Exit Sub
+  
+  ElseIf Abs(x - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     '// 右键排列工具
     TOP_ALIGN_BT.Visible = True
     LEFT_ALIGN_BT.Visible = True
     Exit Sub
 
-  ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
+  ElseIf Abs(x - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then
     '// 右键扩展工具栏收缩
     Me.Height = 30
     Exit Sub
@@ -201,59 +235,61 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   End If
   
   '// 鼠标左键 单击按钮功能  按工具栏上图标正常功能
-  If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  If Abs(x - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     裁切线.start
     
-  ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     剪贴板尺寸建立矩形.start
     
-  ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     裁切线.SelectLine_to_Cropline
     
-  ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     拼版裁切线.arrange
     
-  ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     拼版裁切线.Cut_lines
     
-  ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     自动中线色阶条.Auto_ColorMark
     
-  ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     智能群组和查找.智能群组
     
-  ElseIf Abs(X - pos_x(7)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(7)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     CQL_FIND_UI.Show 0
     
-  ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     Replace_UI.Show 0
     
-  ElseIf Abs(X - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     Tools.TextShape_ConvertToCurves
     
-  ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+  ElseIf Abs(x - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     '// 扩展工具栏
     Me.Height = 30 + 45
     
     Speak_Msg "左右键有不同功能"
     
-  ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    '// 最小化
-    Me.Width = 30
-    Me.Height = 30
-    OPEN_UI_BIG.Left = 61
-    UI.Visible = False
-    LOGO.Visible = True
-    X_EXIT.Visible = True
-    
-    ' 保存工具条位置 Left 和 Top
-    SaveSetting "262235.xyz", "Settings", "Left", Me.Left
-    SaveSetting "262235.xyz", "Settings", "Top", Me.Top
+  ElseIf Abs(x - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+    If Me.Height > 30 Then
+      Me.Height = 30
+    Else
+      '// 最小化
+      Me.Width = 30
+      Me.Height = 30
+      OPEN_UI_BIG.Left = 31
+      UI.Visible = False
+      LOGO.Visible = True
   
-    Speak_Msg "左键缩小 右键收缩"
+      ' 保存工具条位置 Left 和 Top
+      SaveSetting "262235.xyz", "Settings", "Left", Me.Left
+      SaveSetting "262235.xyz", "Settings", "Top", Me.Top
+    
+      Speak_Msg "左键缩小 右键收缩"
+    End If
   End If
 
-
 End Sub
 
 Private Sub X_EXIT_Click()
@@ -267,7 +303,9 @@ Private Sub 调用多页合并工具()
 End Sub
 
 
-Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+'''///  贪心商人和好玩工具等  ///'''
+
+Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     TSP.Nodes_To_TSP
   ElseIf Shift = fmCtrlMask Then
@@ -277,23 +315,23 @@ Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
   End If
 End Sub
 
-Private Sub Cdr_Nodes_BT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Cdr_Nodes_BT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   TSP_L1.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub START_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub START_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   TSP_L2.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub PATH_TO_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub PATH_TO_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   TSP_L3.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub TSP2DRAW_LINE_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub TSP2DRAW_LINE_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   TSP_L4.ForeColor = RGB(0, 150, 255)
 End Sub
 
-Private Sub TSP2DRAW_LINE_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub TSP2DRAW_LINE_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     TSP.TSP_TO_DRAW_LINE
   ElseIf Shift = fmCtrlMask Then
@@ -312,32 +350,35 @@ Private Sub PATH_TO_TSP_Click()
   TSP.MAKE_TSP
 End Sub
 
-Private Sub QR2Vector_Click()
-  Tools.QRCode_to_Vector
+Private Sub BITMAP_BUILD_Click()
+  Tools.Python_BITMAP
 End Sub
 
+Private Sub BITMAP_BUILD2_Click()
+  Tools.Python_BITMAP2
+End Sub
 
 Private Sub BITMAP_MAKE_DOTS_Click()
-  Tools.Python_BITMAP
   TSP.BITMAP_MAKE_DOTS
 End Sub
 
-
-Private Sub CBPY01_Click()
+'''///  Python脚本和二维码等  ///'''
+Private Sub Organize_Size_Click()
   Tools.Python_Organize_Size
-  Me.Height = 30
 End Sub
 
-Private Sub CBPY02_Click()
+Private Sub Get_Number_Click()
   Tools.Python_Get_Barcode_Number
-  Me.Height = 30
 End Sub
 
-Private Sub CBPY03_Click()
+Private Sub Make_QRCode_Click()
   Tools.Python_Make_QRCode
   Tools.QRCode_replace
 End Sub
 
+Private Sub QR2Vector_Click()
+  Tools.QRCode_to_Vector
+End Sub
 
 Private Sub OPEN_UI_BIG_Click()
   Unload Me
@@ -363,11 +404,11 @@ End Sub
 
 Private Sub Tools_Icon_Click()
   ' 调用语句
-  i = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
+  I = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
 End Sub
 
 '''////  选择多物件，组合然后拆分线段，为角线爬虫准备  ////'''
-Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     MsgBox "鼠标右键，功能待定"
     Exit Sub
@@ -378,7 +419,7 @@ Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
   End If
 End Sub
 
-Private Sub Split_Segment_Copy_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Split_Segment_Copy_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     MsgBox "鼠标右键，功能待定"
     Exit Sub
@@ -391,7 +432,7 @@ Private Sub Split_Segment_Copy_MouseDown(ByVal Button As Integer, ByVal Shift As
 End Sub
 
 '''////  CorelDRAW 与 Adobe_Illustrator 剪贴板转换  ////'''
-Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   Dim value As Integer
   If Button = 2 Then
     value = GMSManager.RunMacro("AIClipboard", "CopyPaste.PasteAIFormat")
@@ -405,7 +446,7 @@ Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As
 End Sub
 
 '''////  标记画框 支持容差  ////'''
-Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Mark_CreateRectangle True
   ElseIf Shift = fmCtrlMask Then
@@ -417,7 +458,7 @@ Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift
 End Sub
 
 '''////  一键拆开多行组合的文字字符  ////'''
-Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Batch_Combine
   ElseIf Shift = fmCtrlMask Then
@@ -430,7 +471,7 @@ Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
 End Sub
 
 '''////  简单一刀切  ////'''
-Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Single_Line_Vertical
   ElseIf Shift = fmCtrlMask Then
@@ -443,7 +484,7 @@ Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Intege
 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.傻瓜火车排列 3#
   ElseIf Shift = fmCtrlMask Then
@@ -454,7 +495,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.傻瓜阶梯排列 3#
   ElseIf Shift = fmCtrlMask Then
@@ -465,10 +506,10 @@ Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
 End Sub
 
 
-'''////  多页合并一页工具  ////'''
-Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+'''////  左键-多页合并一页工具   右键-批量多页居中 ////'''
+Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
-    ' 右键
+    Tools.批量多页居中
   ElseIf Shift = fmCtrlMask Then
     UniteOne.Show 0
     Speak_Msg "多页合并一页"
@@ -484,9 +525,50 @@ Private Sub AdobeThumbnail_Click()
     App = mypath & "GuiAdobeThumbnail.exe"
     
     h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
-    i = ShellExecute(h, "", App, "", mypath, 1)
+    I = ShellExecute(h, "", App, "", mypath, 1)
 End Sub
 
+'''////  快速颜色选择  ////'''
 Private Sub Quick_Color_Select_Click()
   Tools.quickColorSelect
 End Sub
+
+Private Sub Cut_Cake_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Tools.divideVertically
+  ElseIf Shift = fmCtrlMask Then
+    Tools.divideHorizontally
+  Else
+    ' Ctrl + 鼠标  空
+  End If
+End Sub
+
+'// 安全辅助线功能，三键控制，讨厌辅助线的也可以用来删除辅助线
+Private Sub Safe_Guideangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Tools.guideangle CorelDRAW.ActiveSelectionRange, 0#   ' 右键 0距离贴紧
+  ElseIf Shift = fmCtrlMask Then
+    Tools.guideangle CorelDRAW.ActiveSelectionRange, 4    ' 左键安全范围 4mm
+  Else
+    Tools.guideangle CorelDRAW.ActiveSelectionRange, -Set_Space_Width     ' Ctrl + 鼠标左键
+  End If
+End Sub
+
+
+'// 小工具快速启动
+Private Sub Open_Calc_Click()
+  Launcher.START_Calc
+End Sub
+
+Private Sub Open_Notepad_Click()
+  Launcher.START_Notepad
+End Sub
+
+Private Sub terminal_Click()
+  Launcher.START_GitBash
+End Sub
+
+Private Sub Video_Camera_Click()
+  Launcher.START_Bandicam
+End Sub
+

UI/UniteOne.bas

@@ -13,18 +13,14 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
-
+Option Explicit
 #If VBA7 Then
-    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
-
 #Else
-    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
-
 #End If
-Option Explicit
-
 
  Dim iHang, iLie, iPages As Integer     '定义行数(Y) 列数(X)
  Dim iYouyi, iXiayi As Single   '右移(R) 下移(B)
@@ -48,7 +44,7 @@ Private Sub cmdRun_Click()
  For Each p In ActiveDocument.Pages
     p.Activate                    '激活每页
     p.Shapes.All.CreateSelection          '每页全选
-    Set s(p.Index) = ActiveSelection.Group    '存放每页的群组
+    Set s(p.index) = ActiveSelection.Group    '存放每页的群组
  Next p
  
  ActiveDocument.EditAcrossLayers = True     '跨图层编辑开启
@@ -58,8 +54,8 @@ Private Sub cmdRun_Click()
   For Each p In ActiveDocument.Pages
     p.Activate
        
-    s(p.Index).MoveToLayer ActivePage.DesktopLayer    '每页对象移动到桌面层
-    s(p.Index).Move (iYouyi * x_M), -(300 + iXiayi * y_M) '排列对象  右偏移，下偏移
+    s(p.index).MoveToLayer ActivePage.DesktopLayer    '每页对象移动到桌面层
+    s(p.index).Move (iYouyi * x_M), -(300 + iXiayi * y_M) '排列对象  右偏移，下偏移
   
   y_M = y_M + 1
   
@@ -91,7 +87,7 @@ Private Sub cmdRunX_Click()
  For Each p In ActiveDocument.Pages
     p.Activate                    '激活每页
     p.Shapes.All.CreateSelection          '每页全选
-    Set s(p.Index) = ActiveSelection.Group    '存放每页的群组
+    Set s(p.index) = ActiveSelection.Group    '存放每页的群组
  Next p
  
  ActiveDocument.EditAcrossLayers = True     '跨图层编辑开启
@@ -101,8 +97,8 @@ Private Sub cmdRunX_Click()
   For Each p In ActiveDocument.Pages
     p.Activate
        
-    s(p.Index).MoveToLayer ActivePage.DesktopLayer    '每页对象移动到桌面层
-    s(p.Index).Move (iYouyi * y_M), -(600 + iXiayi * x_M) '排列对象  右偏移，下偏移
+    s(p.index).MoveToLayer ActivePage.DesktopLayer    '每页对象移动到桌面层
+    s(p.index).Move (iYouyi * y_M), -(600 + iXiayi * x_M) '排列对象  右偏移，下偏移
   
   y_M = y_M + 1
   
@@ -129,7 +125,7 @@ Private Sub UserForm_Initialize()
 ActiveDocument.Unit = cdrMillimeter '本文档单位为mm
 
  For Each p In ActiveDocument.Pages
- iPages = p.Index
+ iPages = p.index
  If iPages = 1 Then
   p.Activate
   p.Shapes.All.CreateSelection

donate.md

@@ -12,7 +12,7 @@
 
 | 微信支付 | 支付宝 | TRX 数字货币 |
 | ------- | ------- | ------- |
-| ![](https://262235.xyz/donate/WXPay.png) | ![](https://262235.xyz/donate/AliPay.jpg) | ![](https://262235.xyz/donate/TRX.png) |
+| ![](https://262235.xyz/donate/WXPay.png) | ![](https://262235.xyz/donate/AliPay.jpg) |
 
 ### 捐赠者:
 ```
@@ -32,6 +32,9 @@ A
 哈哈
 深蓝*浅蓝
 壹方-渐变牙刷
+zdj168
+99彩印
+JZ捷众广告
 ```
 
 ### 会员群福利: 

module/API.bas

@@ -1,14 +1,14 @@
 Attribute VB_Name = "API"
 Public Function Speak_Msg(message As String)
-Speak_Help = Val(GetSetting("262235.xyz", "Settings", "SpeakHelp", "1"))
-
-If Val(Speak_Help) = 1 Then
-  Dim sapi
-  Set sapi = CreateObject("sapi.spvoice")
-  sapi.Speak message
-Else
-  ' 不说话
-End If
+  Speak_Help = Val(GetSetting("262235.xyz", "Settings", "SpeakHelp", "1"))
+  
+  If Val(Speak_Help) = 1 Then
+    Dim sapi
+    Set sapi = CreateObject("sapi.spvoice")
+    sapi.Speak message
+  Else
+    ' 不说话
+  End If
 
 End Function
 
@@ -44,7 +44,7 @@ Public Function Set_Space_Width() As Double
   If GlobalUserData.Exists("SpaceWidth", 1) Then
     text = GlobalUserData("SpaceWidth", 1)
   End If
-  text = InputBox("请输入间隔宽度值 0 --> 99", "设置间隔宽度(mm)", text)
+  text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
   If text = "" Then Exit Function
   GlobalUserData("SpaceWidth", 1) = text
   Set_Space_Width = Val(text)
@@ -89,31 +89,88 @@ End Function
 
 '// 对数组进行排序[单维]
 Public Function ArraySort(src As Variant) As Variant
-  Dim out As Long, i As Long, tmp 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
+    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 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 test_ArraySort()
-  Dim arr As Variant, i As Integer
+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
+  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 Sub
+  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
+
 
 Function FindAllShapes() As ShapeRange
   Dim s As Shape

module/CQL查找相同.bas

@@ -1,25 +1,25 @@
 Attribute VB_Name = "CQL查找相同"
 Sub 属性选择()
-  CQL_FIND_UI.show 0
+  CQL_FIND_UI.Show 0
 End Sub
 
 Public Function CQLline_CM100()
   On Error GoTo err
-  Dim cm(5) As Color, i As Long
-  Set cm(0) = CreateCMYKColor(100, 0, 0, 0)  '青
+  Dim cm(5) As Color, I As Long
+  Set cm(0) = CreateCMYKColor(100, 0, 100, 0)  '绿
   Set cm(1) = CreateCMYKColor(0, 100, 0, 0)  '洋红
-  Set cm(2) = CreateCMYKColor(100, 100, 0, 0) '洋红
+  Set cm(2) = CreateCMYKColor(100, 100, 0, 0) '红
   Set cm(3) = CreateRGBColor(0, 255, 0) ' RGB 绿
   Set cm(4) = CreateRGBColor(255, 0, 0) ' RGB 红
 
-ActiveDocument.ClearSelection
-For i = 0 To 4
-  cm(i).ConvertToRGB
-  r = cm(i).RGBRed
-  G = cm(i).RGBGreen
-  b = cm(i).RGBBlue
-  ActivePage.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").AddToSelection
-Next i
+  ActiveDocument.ClearSelection
+  For I = 0 To 4
+    cm(I).ConvertToRGB
+    r = cm(I).RGBRed
+    G = cm(I).RGBGreen
+    B = cm(I).RGBBlue
+    ActivePage.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & B & "']").AddToSelection
+  Next I
 
 Exit Function
 err:

module/Launcher.bas

@@ -0,0 +1,27 @@
+Attribute VB_Name = "Launcher"
+'// 运行计算器
+Public Function START_Calc()
+    Shell "Calc"
+End Function
+
+
+'// 记事本打开备忘录
+Public Function START_Notepad()
+    cmd_line = "Notepad  C:\TSP\备忘录.txt"
+    Shell cmd_line, vbNormalNoFocus
+End Function
+
+
+'// 记事本打开备忘录
+Public Function START_GitBash()
+    cmd_line = "cmd"
+    Shell cmd_line, vbNormalNoFocus
+End Function
+
+
+'// 记事本打开备忘录
+Public Function START_Bandicam()
+    cmd_line = "C:\Program Files (x86)\Bandicam\BandicamPortable.exe"
+    Shell cmd_line, vbNormalNoFocus
+End Function
+

module/TSP.bas

@@ -1,33 +1,34 @@
 Attribute VB_Name = "TSP"
+'// 导出节点信息到数据文件
 Public Function CDR_TO_TSP()
   Set fs = CreateObject("Scripting.FileSystemObject")
-  Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
+  Set F = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
   
   ActiveDocument.Unit = cdrMillimeter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, Y As Double
   Set shs = ActiveSelection.Shapes
   
   Dim TSP As String
   TSP = shs.Count & " " & 0 & vbNewLine
   For Each sh In shs
-    X = sh.CenterX
+    x = sh.CenterX
     Y = sh.CenterY
-    TSP = TSP & X & " " & Y & vbNewLine
+    TSP = TSP & x & " " & Y & vbNewLine
   Next sh
   
-  f.WriteLine TSP
-  f.Close
+  F.WriteLine TSP
+  F.Close
   MsgBox "小圆点导出节点信息到数据文件!" & vbNewLine
 End Function
 
-
+'// 导出节点信息到数据文件
 Public Function Nodes_To_TSP()
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   
   Set fs = CreateObject("Scripting.FileSystemObject")
-  Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
+  Set F = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
   ActiveDocument.Unit = cdrMillimeter
   
   Dim ssr As ShapeRange
@@ -36,7 +37,7 @@ Public Function Nodes_To_TSP()
   Dim nr As NodeRange
   Dim nd As Node
   
-  Dim X As String, Y As String
+  Dim x As String, Y As String
   Dim TSP As String
   
   Set s = ssr.UngroupAllEx.Combine
@@ -44,13 +45,13 @@ Public Function Nodes_To_TSP()
   
   TSP = nr.Count & " " & 0 & vbNewLine
   For Each n In nr
-      X = Round(n.PositionX, 3) & " "
+      x = Round(n.PositionX, 3) & " "
       Y = Round(n.PositionY, 3) & vbNewLine
-      TSP = TSP & X & Y
+      TSP = TSP & x & Y
   Next n
   
-  f.WriteLine TSP
-  f.Close
+  F.WriteLine TSP
+  F.Close
   s.Delete
   MsgBox "选择物件导出节点信息到数据文件!" & vbNewLine
   
@@ -63,21 +64,21 @@ ErrorHandler:
   On Error Resume Next
 End Function
 
-
+'// 运行CDR2TSP.exe
 Public Function START_TSP()
     cmd_line = "C:\TSP\CDR2TSP.exe C:\TSP\CDR_TO_TSP"
     Shell cmd_line
 End Function
 
-
+'//  TSP功能画线-连贯线
 Public Function TSP_TO_DRAW_LINE()
   On Error GoTo ErrorHandler
   ActiveDocument.Unit = cdrMillimeter
   
   Set fs = CreateObject("Scripting.FileSystemObject")
-  Set f = fs.OpenTextFile("C:\TSP\TSP.txt", 1, False)
+  Set F = fs.OpenTextFile("C:\TSP\TSP.txt", 1, False)
   Dim Str, arr, n
-  Str = f.ReadAll()
+  Str = F.ReadAll()
   
   Str = VBA.replace(Str, vbNewLine, " ")
   Do While InStr(Str, "  ")
@@ -91,17 +92,17 @@ Public Function TSP_TO_DRAW_LINE()
   Dim crv As Curve
   
   ce(0).ElementType = cdrElementStart
-  ce(0).PositionX = 0
-  ce(0).PositionY = 0
+  ce(0).PositionX = Val(arr(2)) - 3    '// 线条起始坐标，偏移3mm方向指示
+  ce(0).PositionY = Val(arr(3)) - 3
   
-  Dim X As Double
+  Dim x As Double
   Dim Y As Double
   For n = 2 To UBound(arr) - 1 Step 2
-    X = Val(arr(n))
+    x = Val(arr(n))
     Y = Val(arr(n + 1))
   
     ce(n / 2).ElementType = cdrElementLine
-    ce(n / 2).PositionX = X
+    ce(n / 2).PositionX = x
     ce(n / 2).PositionY = Y
   
   Next
@@ -114,22 +115,23 @@ ErrorHandler:
   On Error Resume Next
 End Function
 
-
+'// 设置线条标记(颜色)
 Private Function set_line_color(line As Shape)
-   '// 设置线条标记
   line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
 End Function
 
+
+'//  TSP功能画线-多线段
 Public Function TSP_TO_DRAW_LINES()
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup: Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
   
   Set fs = CreateObject("Scripting.FileSystemObject")
-  Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
+  Set F = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
   Dim Str, arr, n
   Dim line As Shape
-  Str = f.ReadAll()
+  Str = F.ReadAll()
   
   Str = VBA.replace(Str, vbNewLine, " ")
   Do While InStr(Str, "  ")
@@ -138,12 +140,12 @@ Public Function TSP_TO_DRAW_LINES()
   
   arr = Split(Str)
   For n = 2 To UBound(arr) - 1 Step 4
-    X = Val(arr(n))
+    x = Val(arr(n))
     Y = Val(arr(n + 1))
     x1 = Val(arr(n + 2))
     y1 = Val(arr(n + 3))
 
-    Set line = ActiveLayer.CreateLineSegment(X, Y, x1, y1)
+    Set line = ActiveLayer.CreateLineSegment(x, Y, x1, y1)
     set_line_color line
   Next
   
@@ -159,26 +161,27 @@ ErrorHandler:
     On Error Resume Next
 End Function
 
+'// 运行 TSP.exe
 Public Function MAKE_TSP()
     cmd_line = "C:\TSP\TSP.exe"
     Shell cmd_line
 End Function
 
-' 位图制作小圆点
+'// 位图制作小圆点
 Public Function BITMAP_MAKE_DOTS()
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup: Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
   Dim line, art, n, h, w
-  Dim X As Double
+  Dim x As Double
   Dim Y As Double
   Dim s As Shape
   flag = 0
   
   Set fs = CreateObject("Scripting.FileSystemObject")
-  Set f = fs.OpenTextFile("C:\TSP\BITMAP", 1, False)
+  Set F = fs.OpenTextFile("C:\TSP\BITMAP", 1, False)
 
-  line = f.ReadLine()
+  line = F.ReadLine()
   Debug.Print line
 
   ' 读取第一行，位图 h高度 和 w宽度
@@ -190,20 +193,20 @@ Public Function BITMAP_MAKE_DOTS()
       flag = 1
   End If
 
-  For i = 1 To h
-    line = f.ReadLine()
+  For I = 1 To h
+    line = F.ReadLine()
     arr = Split(line)
     For n = LBound(arr) To UBound(arr)
       If arr(n) > 0 Then
-        X = n: Y = -i
+        x = n: Y = -I
         If flag = 1 Then
-          Set s = ActiveLayer.CreateRectangle2(X, Y, 0.6, 0.6)
+          Set s = ActiveLayer.CreateRectangle2(x, Y, 0.6, 0.6)
         Else
-          make_dots X, Y
+          make_dots x, Y
         End If
       End If
     Next n
-  Next i
+  Next I
 
   ActiveDocument.EndCommandGroup: Application.Optimization = False
   ActiveWindow.Refresh: Application.Refresh
@@ -213,11 +216,12 @@ ErrorHandler:
     On Error Resume Next
 End Function
 
-Private Function make_dots(X As Double, Y As Double)
+'// 坐标绘制圆点
+Private Function make_dots(x As Double, Y As Double)
   Dim s As Shape
   Dim c As Variant
   c = Array(0, 255, 0)
-  Set s = ActiveLayer.CreateEllipse2(X, Y, 0.5, 0.5)
+  Set s = ActiveLayer.CreateEllipse2(x, Y, 0.5, 0.5)
   s.Fill.UniformColor.RGBAssign c(Int(Rnd() * 2)), c(Int(Rnd() * 2)), c(Int(Rnd() * 2))
   s.Outline.Width = 0#
 End Function

module/Tools.bas

@@ -7,9 +7,9 @@ Public Function 分分合合()
   拼版裁切线.Cut_lines
 
   ' 记忆选择范围
-  Dim X As Double, Y As Double, w As Double, h As Double
-  ActiveSelectionRange.GetBoundingBox X, Y, w, h
-  Set s = ActivePage.SelectShapesFromRectangle(X, Y, w, h, True)
+  Dim x As Double, Y As Double, w As Double, h As Double
+  ActiveSelectionRange.GetBoundingBox x, Y, w, h
+  Set s = ActivePage.SelectShapesFromRectangle(x, Y, w, h, True)
   
   自动中线色阶条.Auto_ColorMark
 
@@ -73,6 +73,7 @@ End Function
 
 '// 文本转曲线
 Public Function TextShape_ConvertToCurves()
+  On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   Dim s As Shape, cnt As Long
   For Each s In API.FindAllShapes.Shapes.FindShapes(, cdrTextShape)
@@ -84,6 +85,10 @@ Public Function TextShape_ConvertToCurves()
   ActiveDocument.EndCommandGroup
   Application.Optimization = False
   ActiveWindow.Refresh:    Application.Refresh
+  Exit Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
 End Function
 
 '' 复制物件
@@ -144,6 +149,8 @@ End Function
 Public Function 尺寸取整()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   ActiveDocument.Unit = cdrMillimeter
+  ' 修改变形尺寸基准
+  ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes
   Set shs = ActiveSelection.Shapes
   Dim s As String, size As String
@@ -197,6 +204,12 @@ Public Function Python_BITMAP()
     Shell cmd_line
 End Function
 
+Public Function Python_BITMAP2()
+    Bitmap = "C:\TSP\BITMAP.exe"
+    Shell Bitmap
+End Function
+
+
 Public Function Python_Make_QRCode()
     mypy = Path & "GMS\262235.xyz\Make_QRCode.py"
     cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
@@ -211,7 +224,7 @@ Public Function QRCode_replace()
   image_path = API.GetClipBoardString
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, Y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -223,11 +236,11 @@ Public Function QRCode_replace()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
+    sh.GetPosition x, Y
+    sc.SetPosition x, Y
     
-    sh.GetSize X, Y
-    sc.SetSize X, Y
+    sh.GetSize x, Y
+    sc.SetSize x, Y
     sh.Delete
     
   Next sh
@@ -326,37 +339,37 @@ End Function
 
 Private Function mark_shape_expand(sh As Shape, tr As Double)
     Dim s As Shape
-    Dim X As Double, Y As Double, w As Double, h As Double, r As Double
-    sh.GetBoundingBox X, Y, w, h
-    X = X - tr: Y = Y - tr:   w = w + 2 * tr: h = h + 2 * tr
+    Dim x As Double, Y As Double, w As Double, h As Double, r As Double
+    sh.GetBoundingBox x, Y, w, h
+    x = x - tr: Y = Y - tr:   w = w + 2 * tr: h = h + 2 * tr
     
     r = Max(w, h) / Min(w, h) / 30 * Math.Sqr(w * h)
     If w < h Then
-      Set s = ActiveLayer.CreateRectangle2(X - r, Y, w + 2 * r, h)
+      Set s = ActiveLayer.CreateRectangle2(x - r, Y, w + 2 * r, h)
     Else
-      Set s = ActiveLayer.CreateRectangle2(X, Y - r, w, h + 2 * r)
+      Set s = ActiveLayer.CreateRectangle2(x, Y - r, w, h + 2 * r)
     End If
     s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
 End Function
 
 Private Function mark_shape(sh As Shape)
   Dim s As Shape
-  Dim X As Double, Y As Double, w As Double, h As Double
-  sh.GetBoundingBox X, Y, w, h
-  Set s = ActiveLayer.CreateRectangle2(X, Y, w, h)
+  Dim x As Double, Y As Double, w As Double, h As Double
+  sh.GetBoundingBox x, Y, w, h, True
+  Set s = ActiveLayer.CreateRectangle2(x, Y, w, h)
   s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
 End Function
 
-Private Function Max(ByVal a, ByVal b)
-  If a < b Then
-    a = b
+Private Function Max(ByVal a, ByVal B)
+  If a < B Then
+    a = B
   End If
     Max = a
 End Function
 
-Private Function Min(ByVal a, ByVal b)
-  If a > b Then
-    a = b
+Private Function Min(ByVal a, ByVal B)
+  If a > B Then
+    a = B
   End If
     Min = a
 End Function
@@ -397,9 +410,9 @@ Public Function Take_Apart_Character()
   Dim tr As Double
   
   ' 记忆选择范围
-  Dim X As Double, Y As Double, w As Double, h As Double
-  ssr.GetBoundingBox X, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
+  Dim x As Double, Y As Double, w As Double, h As Double
+  ssr.GetBoundingBox x, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
   
   ' 解散群组，先组合，再散开
   Set s = ssr.UngroupAllEx.Combine
@@ -471,10 +484,10 @@ Public Function Single_Line()
   End If
     
   ' 记忆选择范围
-  Dim X As Double, Y As Double, w As Double, h As Double
+  Dim x As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox X, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
+  ssr.GetBoundingBox x, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
   s1.Outline.SetProperties Color:=cm(0)
   SrNew.Add s1
   
@@ -534,10 +547,10 @@ Public Function Single_Line_Vertical()
   End If
     
   ' 记忆选择范围
-  Dim X As Double, Y As Double, w As Double, h As Double
+  Dim x As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox X, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
+  ssr.GetBoundingBox x, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
   s1.Outline.SetProperties Color:=cm(0)
   SrNew.Add s1
   
@@ -571,8 +584,8 @@ End Function
 
 Public Function Single_Line_LastNode()
   If 0 = ActiveSelectionRange.Count Then Exit Function
-'  On Error GoTo ErrorHandler
-'  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
   
   Dim cm(2)  As Color
@@ -593,10 +606,10 @@ Public Function Single_Line_LastNode()
   End If
     
   ' 记忆选择范围
-  Dim X As Double, Y As Double, w As Double, h As Double
+  Dim x As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox X, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
+  ssr.GetBoundingBox x, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
   s1.Outline.SetProperties Color:=cm(0)
   SrNew.Add s1
   
@@ -637,17 +650,17 @@ Public Function Mark_Range_Box()
   Dim s1 As Shape, ssr As ShapeRange
   
   Set ssr = ActiveSelectionRange
-  Dim X As Double, Y As Double, w As Double, h As Double
+  Dim x As Double, Y As Double, w As Double, h As Double
 
-  ssr.GetBoundingBox X, Y, w, h
-  Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
+  ssr.GetBoundingBox x, Y, w, h
+  Set s1 = ActiveLayer.CreateRectangle2(x, Y, w, h)
   s1.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0) ' RGB 绿
 End Function
 
 
 '''//// 快速颜色选择 ////'''
-Sub quickColorSelect()
-    Dim X As Double, Y As Double
+Function quickColorSelect()
+    Dim x As Double, Y As Double
     Dim s As Shape, s1 As Shape
     Dim sr As ShapeRange, sr2 As ShapeRange
     Dim Shift As Long, bClick As Boolean
@@ -660,9 +673,9 @@ Sub quickColorSelect()
     bClick = False
     While Not bClick
     On Error Resume Next
-        bClick = ActiveDocument.GetUserClick(X, Y, Shift, 10, False, cdrCursorPickNone)
+        bClick = ActiveDocument.GetUserClick(x, Y, Shift, 10, False, cdrCursorPickNone)
         If Not bClick Then
-            Set s = ActivePage.SelectShapesAtPoint(X, Y, False)
+            Set s = ActivePage.SelectShapesAtPoint(x, Y, False)
             Set s = s.Shapes.Last
             c2.CopyAssign s.Fill.UniformColor
             Set sr2 = New ShapeRange
@@ -678,5 +691,159 @@ Sub quickColorSelect()
     Wend
     
     EventsEnabled = True
-End Sub
+End Function
+
+
+'''//// 切割图形-垂直分割-水平分割 ////'''
+Function divideVertically()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
+  cutInHalf 1
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+  
+Exit Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
+End Function
+
+Function divideHorizontally()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
+  cutInHalf 2
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+  
+Exit Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
+End Function
+
+Private Function cutInHalf(Optional method As Integer)
+    Dim s As Shape, rect As Shape, rect2 As Shape
+    Dim trimmed1 As Shape, trimmed2 As Shape
+    Dim x As Double, Y As Double, w As Double, h As Double
+    Dim vBool As Boolean
+    Dim leeway As Double
+    Dim sr As ShapeRange, sr2 As New ShapeRange
+    
+    vBool = True
+    If method = 2 Then
+        vBool = False
+    End If
+    leeway = 0.1
+    Set sr = ActiveSelectionRange
+    ActiveDocument.BeginCommandGroup "Cut in half"
+    For Each s In sr
+        s.GetBoundingBox x, Y, w, h
+        
+        If (vBool) Then
+            'vertical slice
+            Set rect = ActiveLayer.CreateRectangle2(x - leeway, Y - leeway, (w / 2) + leeway, h + (leeway * 2))
+            Set rect2 = ActiveLayer.CreateRectangle2(x + (w / 2), Y - leeway, (w / 2) + leeway, h + (leeway * 2))
+        Else
+            Set rect = ActiveLayer.CreateRectangle2(x - leeway, Y - leeway, w + (leeway * 2), (h / 2) + leeway)
+            Set rect2 = ActiveLayer.CreateRectangle2(x - leeway, Y + (h / 2), w + (leeway * 2), (h / 2) + leeway)
+        End If
+        
+        Set trimmed1 = rect.Intersect(s, True, True)
+        rect.Delete
+        Set trimmed2 = rect2.Intersect(s, True, True)
+        s.Delete
+        rect2.Delete
+        sr2.Add trimmed1
+        sr2.Add trimmed2
+    Next s
+    ActiveDocument.EndCommandGroup
+    
+    sr2.CreateSelection
+End Function
+
+
+'// 批量多页居中-遍历批量物件，放置物件到页面
+Public Function 批量多页居中()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+
+  ActiveDocument.Unit = cdrMillimeter
+  Set sr = ActiveSelectionRange
+  total = sr.Count
+
+  '// 建立多页面
+  Set doc = ActiveDocument
+  doc.AddPages (total - 1)
+
+
+#If VBA7 Then
+  sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+#Else
+' X4 不支持 ShapeRange.sort
+#End If
+
+
+  Dim sh As Shape
+  
+  '// 遍历批量物件，放置物件到页面
+  For I = 1 To sr.Count
+    doc.Pages(I).Activate
+    Set sh = sr.Shapes(I)
+    ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
+ 
+   '// 物件居中页面
+#If VBA7 Then
+  ActiveDocument.ClearSelection
+  sh.AddToSelection
+  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
+
+  Next I
+
+  ActiveDocument.EndCommandGroup: Application.Optimization = False
+  ActiveWindow.Refresh:   Application.Refresh
+Exit Function
+
+ErrorHandler:
+  Application.Optimization = False
+  MsgBox "请先选择一些物件"
+  On Error Resume Next
+End Function
+
+
+'// 安全线: 点击一次建立辅助线，再调用清除参考线
+Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
+  Dim sr As ShapeRange
+  Set sr = ActiveDocument.MasterPage.GuidesLayer.FindShapes(Type:=cdrGuidelineShape)
+  If sr.Count <> 0 Then
+    sr.Delete
+    Exit Function
+  End If
+  
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  ActiveDocument.Unit = cdrMillimeter
+
+
+
+  With actnumber
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .TopY - cardblood, 0#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .BottomY + cardblood, 0#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.LeftX + cardblood, 0, 90#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.RightX - cardblood, 0, 90#)
+  End With
+  
+
+
+End Function
 

module/剪贴板尺寸建立矩形.bas

@@ -1,18 +1,18 @@
 Attribute VB_Name = "剪贴板尺寸建立矩形"
 '// Attribute VB_Name = "剪贴板尺寸建立矩形"
 Type Coordinate
-    X As Double
+    x As Double
     Y As Double
 End Type
 Public O_O As Coordinate
 
 Sub start()
     '// 坐标原点
-    O_O.X = 0:   O_O.Y = 0
+    O_O.x = 0:   O_O.Y = 0
     Dim ost As ShapeRange
     Set ost = ActiveSelectionRange
 
-    O_O.X = ost.LeftX
+    O_O.x = ost.LeftX
     O_O.Y = ost.BottomY - 50    '选择物件 下移动 50mm
 
     '// 建立矩形 Width  x Height 单位 mm
@@ -32,16 +32,16 @@ Sub start()
     arr = Split(Str)
     
     ActiveDocument.BeginCommandGroup  '一步撤消'
-    Dim X As Double
+    Dim x As Double
     Dim Y As Double
     For n = LBound(arr) To UBound(arr) - 1 Step 2
         ' MsgBox arr(n)
-        X = Val(arr(n))
+        x = Val(arr(n))
         Y = Val(arr(n + 1))
         
-        If X > 0 And Y > 0 Then
-            Rectangle X, Y
-            O_O.X = O_O.X + X + 30
+        If x > 0 And Y > 0 Then
+            Rectangle x, Y
+            O_O.x = O_O.x + x + 30
         End If
     Next
     ActiveDocument.EndCommandGroup
@@ -55,7 +55,7 @@ Private Function Rectangle(Width As Double, Height As Double)
   Dim s1 As Shape
 
   '// 建立矩形 Width  x Height 单位 mm
-  Set s1 = ActiveLayer.CreateRectangle(O_O.X, O_O.Y, O_O.X + Width, O_O.Y - Height)
+  Set s1 = ActiveLayer.CreateRectangle(O_O.x, O_O.Y, O_O.x + Width, O_O.Y - Height)
   
   '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
   s1.Fill.ApplyNoFill
@@ -66,7 +66,7 @@ Private Function Rectangle(Width As Double, Height As Double)
 
   text = Trim(Str(sw)) + "x" + Trim(Str(sh)) + "mm"
   Set d = ActiveDocument
-  Set size = d.ActiveLayer.CreateArtisticText(O_O.X + sw / 2 - 25, O_O.Y + 10, text, Font:="Tahoma")  '// O_O.y + 10  标注尺寸上移 10mm
+  Set size = d.ActiveLayer.CreateArtisticText(O_O.x + sw / 2 - 25, O_O.Y + 10, text, Font:="Tahoma")  '// O_O.y + 10  标注尺寸上移 10mm
   size.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
 End Function
 
@@ -92,16 +92,16 @@ End Function
 Sub get_all_size()
   ActiveDocument.Unit = cdrMillimeter
   Set fs = CreateObject("Scripting.FileSystemObject")
-  Set f = fs.CreateTextFile("R:\size.txt", True)
+  Set F = fs.CreateTextFile("R:\size.txt", True)
   Dim sh As Shape, shs As Shapes
   Set shs = ActiveSelection.Shapes
   Dim s As String
   For Each sh In shs
     size = Trim(Str(Int(sh.SizeWidth + 0.5))) + "x" + Trim(Str(Int(sh.SizeHeight + 0.5))) + "mm"
-    f.WriteLine (size)
+    F.WriteLine (size)
     s = s + size + vbNewLine
   Next sh
-  f.Close
+  F.Close
   MsgBox "输出物件尺寸信息到文件" & "R:\size.txt" & vbNewLine & s
   API.WriteClipBoard s
 End Sub

module/拼版裁切线.bas

@@ -1,6 +1,6 @@
 Attribute VB_Name = "拼版裁切线"
 Type Coordinate
-  X As Double
+  x As Double
   Y As Double
 End Type
 
@@ -34,25 +34,25 @@ Sub Cut_lines()
   For Each Target In OrigSelection
     Set s1 = Target
     lx = s1.LeftX:   rx = s1.RightX
-    by = s1.BottomY: ty = s1.TopY
+    By = s1.BottomY: ty = s1.TopY
     cx = s1.CenterX: cy = s1.CenterY
     
     '// 范围边界物件判断
-    If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - by) _
+    If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - By) _
       < radius Or Abs(set_ty - ty) < radius Then
       
-      arr = Array(lx, by, rx, by, lx, ty, rx, ty)  '// 物件左下-右下-左上-右上 四个顶点坐标数组
-      For i = 0 To 3
-        dot.X = arr(2 * i)
-        dot.Y = arr(2 * i + 1)
+      arr = Array(lx, By, rx, By, lx, ty, rx, ty)  '// 物件左下-右下-左上-右上 四个顶点坐标数组
+      For I = 0 To 3
+        dot.x = arr(2 * I)
+        dot.Y = arr(2 * I + 1)
         
         '// 范围边界坐标点判断
-        If Abs(set_lx - dot.X) < radius Or Abs(set_rx - dot.X) < radius _
+        If Abs(set_lx - dot.x) < radius Or Abs(set_rx - dot.x) < radius _
               Or Abs(set_by - dot.Y) < radius Or Abs(set_ty - dot.Y) < radius Then
 
             draw_line dot, border  '// 以坐标点和范围边界画裁切线
         End If
-      Next i
+      Next I
     End If
   Next Target
   
@@ -76,17 +76,17 @@ Private Function draw_line(dot As Coordinate, border As Variant)
   Dim line As Shape
 
   If Abs(dot.Y - border(3)) < radius Then
-    Set line = ActiveLayer.CreateLineSegment(dot.X, border(3) + Bleed, dot.X, border(3) + (Line_len + Bleed))
+    Set line = ActiveLayer.CreateLineSegment(dot.x, border(3) + Bleed, dot.x, border(3) + (Line_len + Bleed))
     set_line_color line
   ElseIf Abs(dot.Y - border(2)) < radius Then
-    Set line = ActiveLayer.CreateLineSegment(dot.X, border(2) - Bleed, dot.X, border(2) - (Line_len + Bleed))
+    Set line = ActiveLayer.CreateLineSegment(dot.x, border(2) - Bleed, dot.x, border(2) - (Line_len + Bleed))
     set_line_color line
   End If
   
-  If Abs(dot.X - border(1)) < radius Then
+  If Abs(dot.x - border(1)) < radius Then
     Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.Y, border(1) + (Line_len + Bleed), dot.Y)
     set_line_color line
-  ElseIf Abs(dot.X - border(0)) < radius Then
+  ElseIf Abs(dot.x - border(0)) < radius Then
     Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.Y, border(0) - (Line_len + Bleed), dot.Y)
     set_line_color line
   End If
@@ -99,18 +99,18 @@ Private Function draw_line_按点基准(dot As Coordinate, border As Variant)
   Dim line As Shape
 
   If Abs(dot.Y - border(3)) < radius Then
-    Set line = ActiveLayer.CreateLineSegment(dot.X, dot.Y + Bleed, dot.X, dot.Y + (Line_len + Bleed))
+    Set line = ActiveLayer.CreateLineSegment(dot.x, dot.Y + Bleed, dot.x, dot.Y + (Line_len + Bleed))
     set_line_color line
   ElseIf Abs(dot.Y - border(2)) < radius Then
-    Set line = ActiveLayer.CreateLineSegment(dot.X, dot.Y - Bleed, dot.X, dot.Y - (Line_len + Bleed))
+    Set line = ActiveLayer.CreateLineSegment(dot.x, dot.Y - Bleed, dot.x, dot.Y - (Line_len + Bleed))
     set_line_color line
   End If
   
-  If Abs(dot.X - border(1)) < radius Then
-    Set line = ActiveLayer.CreateLineSegment(dot.X + Bleed, dot.Y, dot.X + (Line_len + Bleed), dot.Y)
+  If Abs(dot.x - border(1)) < radius Then
+    Set line = ActiveLayer.CreateLineSegment(dot.x + Bleed, dot.Y, dot.x + (Line_len + Bleed), dot.Y)
     set_line_color line
-  ElseIf Abs(dot.X - border(0)) < radius Then
-    Set line = ActiveLayer.CreateLineSegment(dot.X - Bleed, dot.Y, dot.X - (Line_len + Bleed), dot.Y)
+  ElseIf Abs(dot.x - border(0)) < radius Then
+    Set line = ActiveLayer.CreateLineSegment(dot.x - Bleed, dot.Y, dot.x - (Line_len + Bleed), dot.Y)
     set_line_color line
   End If
 
@@ -147,11 +147,11 @@ Sub arrange()
   arr = Split(Str)
 
   Dim s1 As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, Y As Double
   
   If 0 = ActiveSelectionRange.Count Then
-    X = Val(arr(0)):    Y = Val(arr(1))
-    row = Int(ActiveDocument.Pages.First.SizeWidth / X)
+    x = Val(arr(0)):    Y = Val(arr(1))
+    row = Int(ActiveDocument.Pages.First.SizeWidth / x)
     List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
 
     If UBound(arr) > 2 Then
@@ -164,7 +164,7 @@ Sub arrange()
     End If
      
     '// 建立矩形 Width  x Height 单位 mm
-    Set s1 = ActiveLayer.CreateRectangle(0, 0, X, Y)
+    Set s1 = ActiveLayer.CreateRectangle(0, 0, x, Y)
     
     '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
     s1.Fill.ApplyNoFill
@@ -174,12 +174,12 @@ Sub arrange()
   '// 如果当前选择物件，按当前物件拼版
   ElseIf 1 = ActiveSelectionRange.Count Then
     Set s1 = ActiveSelection
-    X = s1.SizeWidth:    Y = s1.SizeHeight
-    row = Int(ActiveDocument.Pages.First.SizeWidth / X)
+    x = s1.SizeWidth:    Y = s1.SizeHeight
+    row = Int(ActiveDocument.Pages.First.SizeWidth / x)
     List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
   End If
   
-  sw = X:  sh = Y
+  sw = x:  sh = Y
 
   '// StepAndRepeat 方法在范围内创建多个形状副本
   Dim dup1 As ShapeRange

module/智能群组和查找.bas

@@ -1,6 +1,6 @@
 Attribute VB_Name = "智能群组和查找"
 Sub 剪贴板物件替换()
-  Replace_UI.show 0
+  Replace_UI.Show 0
 End Sub
 
 Public Sub 智能群组(Optional ByVal tr As Double = 0)
@@ -13,16 +13,16 @@ Public Sub 智能群组(Optional ByVal tr As Double = 0)
   
   Dim OrigSelection As ShapeRange, sr As New ShapeRange
   Dim s1 As Shape, sh As Shape, s As Shape
-  Dim X As Double, Y As Double, w As Double, h As Double
+  Dim x As Double, Y As Double, w As Double, h As Double
   Dim eff1 As Effect
   
   Set OrigSelection = ActiveSelectionRange
 
   '// 遍历物件画矩形
   For Each sh In OrigSelection
-    sh.GetBoundingBox X, Y, w, h
+    sh.GetBoundingBox x, Y, w, h
     If w * h > 4 Then
-      Set s = ActiveLayer.CreateRectangle2(X - tr, Y - tr, w + 2 * tr, h + 2 * tr)
+      Set s = ActiveLayer.CreateRectangle2(x - tr, Y - tr, w + 2 * tr, h + 2 * tr)
       sr.Add s
 
     '// 轴线 创建轮廓处理

module/裁切线.bas

@@ -21,17 +21,17 @@ If 0 = ActiveSelectionRange.Count Then Exit Sub
   For Each Target In OrigSelection
     Set s1 = Target
     lx = s1.LeftX:      rx = s1.RightX
-    by = s1.BottomY:    ty = s1.TopY
+    By = s1.BottomY:    ty = s1.TopY
     cx = s1.CenterX:    cy = s1.CenterY
     sw = s1.SizeWidth:  sh = s1.SizeHeight
     
     '//  添加裁切线，分别左下-右下-左上-右上
     Dim s2, s3, s4, s5, s6, s7, s8, s9 As Shape
-    Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, by, lx - (Bleed + Line_len), by)
-    Set s3 = ActiveLayer.CreateLineSegment(lx, by - Bleed, lx, by - (Bleed + Line_len))
+    Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, By, lx - (Bleed + Line_len), By)
+    Set s3 = ActiveLayer.CreateLineSegment(lx, By - Bleed, lx, By - (Bleed + Line_len))
 
-    Set s4 = ActiveLayer.CreateLineSegment(rx + Bleed, by, rx + (Bleed + Line_len), by)
-    Set s5 = ActiveLayer.CreateLineSegment(rx, by - Bleed, rx, by - (Bleed + Line_len))
+    Set s4 = ActiveLayer.CreateLineSegment(rx + Bleed, By, rx + (Bleed + Line_len), By)
+    Set s5 = ActiveLayer.CreateLineSegment(rx, By - Bleed, rx, By - (Bleed + Line_len))
 
     Set s6 = ActiveLayer.CreateLineSegment(lx - Bleed, ty, lx - (Bleed + Line_len), ty)
     Set s7 = ActiveLayer.CreateLineSegment(lx, ty + Bleed, lx, ty + (Bleed + Line_len))
@@ -80,7 +80,7 @@ Sub SelectLine_to_Cropline()
   
     lx = s.LeftX
     rx = s.RightX
-    by = s.BottomY
+    By = s.BottomY
     ty = s.TopY
     
     cx = s.CenterX

python/BITMAP.py

@@ -1,9 +1,14 @@
 from array import array
 import numpy as np
 import cv2 as cv
+from sys import argv
+
+img_file = 'C:\TSP\png.png'
+if (len(argv) > 1) :
+    img_file = argv[1]
 
 # 加载图片到灰度图像
-img = cv.imread('C:\TSP\png.png', cv.IMREAD_GRAYSCALE)
+img = cv.imread(img_file, cv.IMREAD_GRAYSCALE)
 h,w = img.shape
 print(h,w)
 print(img.size)
@@ -15,7 +20,7 @@ f.write(line)
 lst = ['0'] * w
 for m in range(h):
     for n in range(w):
-        if img[m,n] == 0:
+        if img[m,n] < 127:
             lst[n] = '1'
         else:
             lst[n] = '0'