蘭雅CorelVBA工具 UI独立图片 添加语音功能提示

UI/CQL_FIND_UI.bas

@@ -14,10 +14,11 @@ Attribute VB_Creatable = False
 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
     
@@ -40,16 +41,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
@@ -61,41 +62,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
-    my = y
+    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
-    Me.Top = Me.Top - my + y
+  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
   

UI/CorelVBA.bas

@@ -15,11 +15,12 @@ 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
     
@@ -39,26 +40,27 @@ Private Const WS_EX_DLGMODALFRAME = &H1&
 Private switch As Boolean
 
 Private Sub Close_Icon_Click()
+  WebHelp "https://262235.xyz/index.php/tag/vba/"
   Unload Me    ' 关闭
 End Sub
 
 Private Sub ToolBar_show_Click()
   Unload Me
-  Toolbar.Show 0
+  Toolbar.show 0
 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
@@ -74,17 +76,17 @@ 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
-    my = y
+    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.Top = Me.Top - my + y
+    Me.Left = Me.Left - mx + X
+    Me.Top = Me.Top - my + Y
   End If
 End Sub
 
@@ -92,7 +94,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
@@ -100,43 +102,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"
+    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#
@@ -145,12 +147,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
 
@@ -177,7 +179,7 @@ End Sub
 
 Private Sub 批量替换()
   CorelVBA.Hide
-  Replace_UI.Show 0
+  Replace_UI.show 0
 End Sub
 
 Private Sub 拼版标记()
@@ -198,7 +200,7 @@ End Sub
 
 Private Sub CQL选择()
   CorelVBA.Hide
-  CQL_FIND_UI.Show 0
+  CQL_FIND_UI.show 0
 End Sub
 
 

UI/Replace_UI.bas

@@ -14,10 +14,11 @@ Attribute VB_Creatable = False
 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
     
@@ -40,16 +41,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
@@ -61,34 +62,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
-    my = y
+    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.Top = Me.Top - my + 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 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
   
@@ -103,7 +104,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
@@ -115,11 +116,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
@@ -141,7 +142,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
@@ -151,11 +152,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
@@ -178,7 +179,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
@@ -188,8 +189,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

@@ -14,10 +14,11 @@ Attribute VB_Creatable = False
 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
     
@@ -34,19 +35,23 @@ Private Const WS_CAPTION As Long = &HC00000
 Private Const WS_EX_DLGMODALFRAME = &H1&
 
 
+Private Sub CommandButton3_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
@@ -63,12 +68,19 @@ End With
   Bleed.text = API.GetSet("Bleed")
   Line_len.text = API.GetSet("Line_len")
   Outline_Width.text = GetSetting("262235.xyz", "Settings", "Outline_Width", "0.2")
+  
+  
+  UIFile = Path & "GMS\262235.xyz\ToolBar.jpg"
+  If API.ExistsFile_UseFso(UIFile) Then
+    UI.Picture = LoadPicture(UIFile)   '换UI图
+  End If
+  
 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
-        my = y
+        mx = X
+        my = Y
     End If
     
   With Me
@@ -77,15 +89,15 @@ 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.Top = Me.Top - my + y
+    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
@@ -97,19 +109,19 @@ Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVa
   End If
   
   If Button Then
-      mx = x
-      my = y
+      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.Top = Me.Top - my + y
+    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
@@ -118,46 +130,46 @@ 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
     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(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(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
@@ -165,41 +177,43 @@ 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
-    CQL_FIND_UI.Show 0
+  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
-    Replace_UI.Show 0
+  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
     
-  ElseIf Abs(x - pos_x(11)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    Speak_Msg "左右键有不同功能"
+    
+  ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     '// 最小化
     Me.Width = 30
     Me.Height = 30
@@ -207,8 +221,11 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
     UI.Visible = False
     LOGO.Visible = True
     X_EXIT.Visible = True
+    
+    Speak_Msg "左键缩小 右键收缩"
   End If
 
+
 End Sub
 
 
@@ -267,7 +284,7 @@ End Sub
 
 Private Sub OPEN_UI_BIG_Click()
   Unload Me
-  CorelVBA.Show 0
+  CorelVBA.show 0
 End Sub
 
 Private Sub Settings_Click()
@@ -286,11 +303,10 @@ End Sub
 Private Sub Tools_Icon_Click()
   ' 调用语句
   i = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
-  Me.Height = 30
 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
@@ -298,11 +314,10 @@ Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
   
   If Button Then
       Tools.Split_Segment
-  Me.Height = 30
   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
@@ -310,12 +325,12 @@ Private Sub Split_Segment_Copy_MouseDown(ByVal Button As Integer, ByVal Shift As
   
   If Button Then
       Tools.Split_Segment
-  Me.Height = 30
   End If
+  Speak_Msg "拆分线段"
 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)
+'''////  CorelDRAW 与 Adobe_Illustrator 剪贴板转换  ////'''
+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")
@@ -329,7 +344,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
@@ -337,35 +352,37 @@ Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift
   Else
     Create_Tolerance
   End If
+  Speak_Msg "标记画框  右键支持容差"
 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
-    MsgBox "右键暂定功能: 智能群组后的拆开组合"
   ElseIf Shift = fmCtrlMask Then
     Tools.Take_Apart_Character
-    Me.Height = 30
   Else
     Create_Tolerance
   End If
+
+  Speak_Msg "智能拆字"
 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
-    MsgBox "简单一刀切，右键隐藏"
     Me.Height = 30
   ElseIf Shift = fmCtrlMask Then
     Tools.Single_Line
   Else
     ' Ctrl + 鼠标  空
   End If
+  
+  Speak_Msg "简单一刀切"
 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
@@ -376,7 +393,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
@@ -386,3 +403,15 @@ Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
   End If
 End Sub
 
+
+'''////  多页合并一页工具  ////'''
+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
+    ' 右键
+  ElseIf Shift = fmCtrlMask Then
+    UniteOne.show 0
+    Speak_Msg "多页合并一页"
+  Else
+    ' Ctrl + 鼠标  空
+  End If
+End Sub

UI/UniteOne.bas

@@ -0,0 +1,290 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UniteOne 
+   Caption         =   "CorelDRAW 合并多页为一页 蘭雅sRGB 2010-2022"
+   ClientHeight    =   4005
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   5220
+   OleObjectBlob   =   "UniteOne.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "UniteOne"
+Attribute VB_GlobalNameSpace = False
+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 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 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)
+                                'txtHang, txtLie, txtYouyi, txtXiayi ,txtInfo
+ Dim LogoFile As String         'Logo
+ 
+ Dim s(1 To 255) As Shape   '定义对象用于存放每页的群组
+ Dim p As Page          '定义多页
+ 
+
+'**** 主程序  执行
+Private Sub cmdRun_Click()
+  '// 代码运行时关闭窗口刷新
+  Application.Optimization = True
+  ActiveDocument.BeginCommandGroup  '一步撤消'
+
+ Dim x_M, y_M
+ ActiveDocument.Unit = cdrMillimeter
+ ActiveDocument.EditAcrossLayers = False    '跨图层编辑禁止
+ 
+ For Each p In ActiveDocument.Pages
+    p.Activate                    '激活每页
+    p.Shapes.All.CreateSelection          '每页全选
+    Set s(p.Index) = ActiveSelection.Group    '存放每页的群组
+ Next p
+ 
+ ActiveDocument.EditAcrossLayers = True     '跨图层编辑开启
+ 
+  x_M = y_M = 0
+  
+  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) '排列对象  右偏移，下偏移
+  
+  y_M = y_M + 1
+  
+  If y_M = iLie Then
+  x_M = x_M + 1
+  y_M = 0
+  End If
+  
+ Next p
+ 
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh
+  Application.Refresh
+ Unload Me '执行完成关闭
+End Sub
+
+
+'**** 主程序 副本 横排序
+Private Sub cmdRunX_Click()
+  '// 代码运行时关闭窗口刷新
+  Application.Optimization = True
+  ActiveDocument.BeginCommandGroup  '一步撤消'
+
+ Dim x_M, y_M
+ ActiveDocument.Unit = cdrMillimeter
+ ActiveDocument.EditAcrossLayers = False    '跨图层编辑禁止
+ 
+ For Each p In ActiveDocument.Pages
+    p.Activate                    '激活每页
+    p.Shapes.All.CreateSelection          '每页全选
+    Set s(p.Index) = ActiveSelection.Group    '存放每页的群组
+ Next p
+ 
+ ActiveDocument.EditAcrossLayers = True     '跨图层编辑开启
+ 
+  x_M = y_M = 0
+  
+  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) '排列对象  右偏移，下偏移
+  
+  y_M = y_M + 1
+  
+  If y_M = iHang Then
+  x_M = x_M + 1
+  y_M = 0
+  End If
+  
+ Next p
+ 
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh
+  Application.Refresh
+ 
+ Unload Me '执行完成关闭
+End Sub
+
+
+'*********** 初始化程序 ***************
+Private Sub UserForm_Initialize()
+
+ Dim s As Shape
+ActiveDocument.Unit = cdrMillimeter '本文档单位为mm
+
+ For Each p In ActiveDocument.Pages
+ iPages = p.Index
+ If iPages = 1 Then
+  p.Activate
+  p.Shapes.All.CreateSelection
+
+ Set s = ActiveDocument.Selection
+        If s.Shapes.Count = 0 Then
+            MsgBox "当前文件第一页空白没有物件！"
+            Exit Sub
+        End If
+ 
+ End If
+ Next p
+ 
+
+ txtLie.text = 5
+ txtHang.text = Int(iPages / CInt(txtLie.text) + 0.9)
+ txtLie.text = Int(iPages / CInt(txtHang.text) + 0.9)
+ 
+ iHang = CInt(txtHang.text)
+ iLie = CInt(txtLie.text)
+ 
+ 
+ iYouyi = Int(s.SizeWidth + 0.6)
+ iXiayi = Int(s.SizeHeight + 0.6)
+ 
+ txtYouyi.text = iYouyi
+ txtXiayi.text = iXiayi
+ 
+  LogoFile = Path & "GMS\262235.xyz\LOGO.jpg"
+  If API.ExistsFile_UseFso(LogoFile) Then
+    LogoPic.Picture = LoadPicture(LogoFile)   '换LOGO图
+  End If
+  
+ txtInfo.text = "本文档共 " & iPages & " 页，首页物件尺寸(mm):" & s.SizeWidth & "×" & s.SizeHeight
+  
+End Sub
+
+
+
+'帮助
+
+Private Sub cmdHelp_Click()
+
+WebHelp
+
+txtInfo.text = "点击访问 https://262235.xyz 详细帮助,寻找更多的视频教程！"
+txtInfo.ForeColor = &HFF0000
+cmdHelp.Caption = "在线帮助"
+cmdHelp.ForeColor = &HFF0000
+
+
+End Sub
+
+
+'关闭
+Private Sub cmdClose_Click()
+Unload Me
+End Sub
+
+
+'VB限制文本框只能输入数字和小数点
+Private Sub txtHang_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+Dim Numbers As String
+Numbers = "1234567890"
+If InStr(Numbers, Chr(KeyAscii)) = 0 Then
+KeyAscii = 0
+End If
+End Sub
+
+Private Sub txtLie_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+Dim Numbers As String
+Numbers = "1234567890"
+If InStr(Numbers, Chr(KeyAscii)) = 0 Then
+KeyAscii = 0
+End If
+End Sub
+
+Private Sub txtXiayi_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+Dim Numbers As String
+Numbers = "1234567890" + Chr(8) + Chr(46)
+If InStr(Numbers, Chr(KeyAscii)) = 0 Then
+KeyAscii = 0
+End If
+End Sub
+
+Private Sub txtYouyi_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+Dim Numbers As String
+Numbers = "1234567890" + Chr(8) + Chr(46)
+If InStr(Numbers, Chr(KeyAscii)) = 0 Then
+KeyAscii = 0
+End If
+End Sub
+
+Private Sub txtHang_Change()
+    Dim n As Single
+    n = Val(txtHang.text)
+    If n > 0 And n < 1001 Then
+        HangSpin.value = n
+        iHang = n
+    End If
+ 
+ txtHang.text = iHang
+ txtLie.text = Int(iPages / iHang + 0.9)
+ 
+  
+  iLie = CInt(txtLie.text)
+    
+End Sub
+
+Private Sub HangSpin_Change()
+    txtHang.text = CStr(HangSpin.value)
+End Sub
+
+Private Sub txtLie_Change()
+    Dim n As Single
+    n = Val(txtLie.text)
+    If n > 0 And n < 1001 Then
+        LieSpin.value = n
+        iLie = n
+    End If
+    
+    txtLie.text = iLie
+    txtHang.text = Int(iPages / iLie + 0.9)
+    
+    iHang = CInt(txtHang.text)
+End Sub
+
+Private Sub LieSpin_Change()
+    txtLie.text = CStr(LieSpin.value)
+End Sub
+
+
+Private Sub txtXiayi_Change()
+    Dim n As Single
+    n = Val(txtXiayi.text)
+    If n > 0 And n < 1001 Then
+        iXiayi = n
+    End If
+End Sub
+
+Private Sub txtYouyi_Change()
+    Dim n As Single
+    n = Val(txtYouyi.text)
+    If n > 0 And n < 1001 Then
+        iYouyi = n
+    End If
+End Sub
+
+Function WebHelp()
+ Dim h As Long, r As Long
+ 
+ If cmdHelp.Caption = "在线帮助" Then
+ h = FindWindow(vbNullString, "CorelDRAW 合并多页为一页 蘭雅sRGB 2010-2022")
+ r = ShellExecute(h, "", "https://262235.xyz/index.php/tag/vba/", "", "", 1)
+ End If
+End Function
+
+

module/API.bas

@@ -1,4 +1,17 @@
 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
+
+End Function
+
 Public Function GetSet(s As String)
   Bleed = Val(GetSetting("262235.xyz", "Settings", "Bleed", "2.0"))
   Line_len = Val(GetSetting("262235.xyz", "Settings", "Line_len", "3.0"))
@@ -15,7 +28,7 @@ Public Function GetSet(s As String)
   
 End Function
 
-Public Function Create_Tolerance()
+Public Function Create_Tolerance() As Double
   Dim text As String
   If GlobalUserData.Exists("Tolerance", 1) Then
     text = GlobalUserData("Tolerance", 1)
@@ -23,6 +36,7 @@ Public Function Create_Tolerance()
   text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
   If text = "" Then Exit Function
   GlobalUserData("Tolerance", 1) = text
+  Create_Tolerance = Val(text)
 End Function
 
 Public Function Set_Space_Width() As Double
@@ -137,3 +151,11 @@ Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
      Set fso = Nothing
 
 End Function
+
+Function test()
+  Dim message, sapi
+  MsgBox ("Please use the headset and listen to what I have to say...")
+  message = "This is a simple voice test on your Microsoft Windows."
+  Set sapi = CreateObject("sapi.spvoice")
+  sapi.Speak message
+End Function

module/CQL查找相同.bas

@@ -1,6 +1,6 @@
 Attribute VB_Name = "CQL查找相同"
 Sub 属性选择()
-  CQL_FIND_UI.Show 0
+  CQL_FIND_UI.show 0
 End Sub
 
 Public Function CQLline_CM100()

module/CorelVBA窗口.bas

@@ -1,6 +1,8 @@
-Attribute VB_Name = "CorelVBA´°¿Ú"
+Attribute VB_Name = "CorelVBA窗口"
 Public Sub start()
-  Toolbar.Show 0
-' CorelVBA.show 0
+  Toolbar.show 0
+  CorelVBA.show 0
+  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
+  Speak_Msg "感谢您使用 蘭雅VBA工具"
 End Sub
 

module/TSP.bas

@@ -5,15 +5,15 @@ Public Function CDR_TO_TSP()
   
   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
-    y = sh.CenterY
-    TSP = TSP & x & " " & y & vbNewLine
+    X = sh.CenterX
+    Y = sh.CenterY
+    TSP = TSP & X & " " & Y & vbNewLine
   Next sh
   
   f.WriteLine TSP
@@ -28,15 +28,15 @@ Public Function PATH_TO_TSP()
   
   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
-    y = sh.CenterY
-    TSP = TSP & x & " " & y & vbNewLine
+    X = sh.CenterX
+    Y = sh.CenterY
+    TSP = TSP & X & " " & Y & vbNewLine
   Next sh
   
   f.WriteLine TSP
@@ -51,7 +51,7 @@ Public Function START_TSP()
 End Function
 
 Public Function TSP_TO_DRAW_LINE()
- ' On Error GoTo ErrorHandler
+  On Error GoTo ErrorHandler
   ActiveDocument.Unit = cdrMillimeter
   
   Set fs = CreateObject("Scripting.FileSystemObject")
@@ -74,15 +74,15 @@ Public Function TSP_TO_DRAW_LINE()
   ce(0).PositionX = 0
   ce(0).PositionY = 0
   
-  Dim x As Double
-  Dim y As Double
+  Dim X As Double
+  Dim Y As Double
   For n = 2 To UBound(arr) - 1 Step 2
-    x = Val(arr(n))
-    y = Val(arr(n + 1))
+    X = Val(arr(n))
+    Y = Val(arr(n + 1))
   
     ce(n / 2).ElementType = cdrElementLine
-    ce(n / 2).PositionX = x
-    ce(n / 2).PositionY = y
+    ce(n / 2).PositionX = X
+    ce(n / 2).PositionY = Y
   
   Next
   
@@ -115,15 +115,15 @@ Public Function TSP_TO_DRAW_LINE_BAK()
   ce(0).PositionX = 0
   ce(0).PositionY = 0
   
-  Dim x As Double
-  Dim y As Double
+  Dim X As Double
+  Dim Y As Double
   For n = 2 To UBound(arr) - 1 Step 2
-    x = Val(arr(n))
-    y = Val(arr(n + 1))
+    X = Val(arr(n))
+    Y = Val(arr(n + 1))
   
     ce(n / 2).ElementType = cdrElementLine
-    ce(n / 2).PositionX = x
-    ce(n / 2).PositionY = y
+    ce(n / 2).PositionX = X
+    ce(n / 2).PositionY = Y
   
   Next
   
@@ -147,8 +147,8 @@ Public Function BITMAP_MAKE_DOTS()
   ActiveDocument.BeginCommandGroup: Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
   Dim line, art, n, h, w
-  Dim x As Double
-  Dim y As Double
+  Dim X As Double
+  Dim Y As Double
   Dim s As Shape
   flag = 0
   
@@ -172,11 +172,11 @@ Public Function BITMAP_MAKE_DOTS()
     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
@@ -190,11 +190,11 @@ 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
 
@@ -204,7 +204,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
@@ -216,11 +216,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
@@ -319,24 +319,24 @@ 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
+  Set s = ActiveLayer.CreateRectangle2(X, Y, w, h)
   s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
 End Function
 
@@ -390,9 +390,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
@@ -464,10 +464,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
   

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

@@ -1,19 +1,19 @@
 Attribute VB_Name = "剪贴板尺寸建立矩形"
 '// Attribute VB_Name = "剪贴板尺寸建立矩形"
 Type Coordinate
-    x As Double
-    y 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.y = ost.BottomY - 50    '选择物件 下移动 50mm
+    O_O.X = ost.LeftX
+    O_O.Y = ost.BottomY - 50    '选择物件 下移动 50mm
 
     '// 建立矩形 Width  x Height 单位 mm
     Dim Str, arr, n
@@ -32,16 +32,16 @@ Sub start()
     arr = Split(Str)
     
     ActiveDocument.BeginCommandGroup  '一步撤消'
-    Dim x As Double
-    Dim y 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))
-        y = Val(arr(n + 1))
+        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
 

module/拼版裁切线.bas

@@ -1,7 +1,7 @@
 Attribute VB_Name = "拼版裁切线"
 Type Coordinate
-  x As Double
-  y As Double
+  X As Double
+  Y As Double
 End Type
 
 Sub Cut_lines()
@@ -43,12 +43,12 @@ Sub Cut_lines()
       
       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)
+        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 _
-              Or Abs(set_by - dot.y) < radius Or Abs(set_ty - dot.y) < radius Then
+        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
@@ -75,19 +75,19 @@ Private Function draw_line(dot As Coordinate, border As Variant)
   radius = border(6): Bleed = border(7):  Line_len = border(8)
   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))
+  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_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))
+  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_color line
   End If
   
-  If Abs(dot.x - border(1)) < radius Then
-    Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.y, border(1) + (Line_len + Bleed), dot.y)
+  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
-    Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.y, border(0) - (Line_len + Bleed), dot.y)
+  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
 
@@ -98,19 +98,19 @@ Private Function draw_line_按点基准(dot As Coordinate, border As Variant)
   Bleed = 2:  Line_len = 3:  radius = border(6)
   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))
+  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_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))
+  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_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,12 +147,12 @@ 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)
-    List = Int(ActiveDocument.Pages.First.SizeHeight / y)
+    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
     row = Val(arr(2)):  List = Val(arr(3))
@@ -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)
-    List = Int(ActiveDocument.Pages.First.SizeHeight / y)
+    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
@@ -189,6 +189,7 @@ Sub arrange()
        
   Exit Sub
 ErrorHandler:
+  Speak_Msg "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
   MsgBox "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
   On Error Resume Next
 End Sub

module/智能群组和查找.bas

@@ -1,9 +1,9 @@
 Attribute VB_Name = "智能群组和查找"
 Sub 剪贴板物件替换()
-  Replace_UI.Show 0
+  Replace_UI.show 0
 End Sub
 
-Public Sub 智能群组()
+Public Sub 智能群组(Optional ByVal tr As Double = 0)
   If 0 = ActiveSelectionRange.Count Then Exit Sub
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
@@ -13,16 +13,16 @@ Public Sub 智能群组()
   
   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, y, w, h)
+      Set s = ActiveLayer.CreateRectangle2(X - tr, Y - tr, w + 2 * tr, h + 2 * tr)
       sr.Add s
 
     '// 轴线 创建轮廓处理