Module and function names changed to English

UI/ArrangeForm.bas

@@ -17,6 +17,7 @@ Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
+
 Private Sub CommandButton1_Click()
   On Error GoTo ErrorHandler
   ActiveDocument.Unit = cdrMillimeter
@@ -61,10 +62,10 @@ End Sub
 Private Function arrange_Clone(matrix As Variant, s As ShapeRange)
   ls = matrix(0): hs = matrix(1)
   lj = matrix(2): hj = matrix(3)
-  x = s.SizeWidth: Y = s.SizeHeight
+  X = s.SizeWidth: Y = s.SizeHeight
   Set s1 = s.Clone
   '// StepAndRepeat 方法在范围内创建多个形状副本
-  Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
+  Set dup1 = s1.StepAndRepeat(ls - 1, X + lj, 0#)
   Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
   s1.Delete
 End Function
@@ -72,11 +73,11 @@ End Function
 Private Function arrange_Clone_one(matrix As Variant, s As ShapeRange)
   ls = matrix(0): hs = matrix(1)
   lj = matrix(2): hj = matrix(3)
-  x = s.SizeWidth: Y = s.SizeHeight
+  X = s.SizeWidth: Y = s.SizeHeight
   Set s1 = s.Clone
   '// StepAndRepeat 方法在范围内创建多个形状副本
   If ls > 1 Then
-    Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
+    Set dup1 = s1.StepAndRepeat(ls - 1, X + lj, 0#)
   Else
     Set dup1 = s1
   End If

UI/CQL_FIND_UI.bas

@@ -1,10 +1,9 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CQL_FIND_UI 
-   Caption         =   "使剪贴板上的物件替换选择的目标物件"
-   ClientHeight    =   4575
+   ClientHeight    =   7830
    ClientLeft      =   45
    ClientTop       =   330
-   ClientWidth     =   7575
+   ClientWidth     =   11610
    OleObjectBlob   =   "CQL_FIND_UI.frx":0000
    StartUpPosition =   1  '所有者中心
 End
@@ -13,8 +12,8 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
-
-
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
 
 #If VBA7 Then
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
@@ -35,10 +34,6 @@ Private Const GWL_EXSTYLE = (-20)
 Private Const WS_CAPTION As Long = &HC00000
 Private Const WS_EX_DLGMODALFRAME = &H1&
 
-Private Sub Close_Icon_Click()
-  Unload Me    ' 关闭
-End Sub
-
 
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
@@ -61,49 +56,111 @@ Private Sub UserForm_Initialize()
     .Height = 228
   End With
   
+  txtInfo.text = "Usage: A->Left B->Right C->Ctrl"
 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
-    CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
+  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
+    API.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
-    CQL查找相同.CQLline_CM100
+    '// 预置颜色轮廓选择    和 '// 彩蛋功能
+  If Abs(X - 178) < 30 And Abs(Y - 118) < 30 = True Then
+    Image1.Visible = False
+    Close_Icon.Visible = False
+    X_EXIT.Visible = True
+    
+    With CQL_FIND_UI
+      .StartUpPosition = 0
+      .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400")) + 318
+      .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55")) - 2
+      .Height = 30
+      .Width = .Width - 20
+    End With
+    
+    If OptBt.value Then
+      frmSelectSame.Show 0
+    Else
+      CQLFindSame.CQLline_CM100
+    End If
+    Exit Sub
   End If
-  
   CQL_FIND_UI.Hide
 End Sub
 
+Private Sub MADD_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Store_Instruction 2, "add"
+  ElseIf Shift = fmCtrlMask Then
+    Store_Instruction 1, "add"
+  Else
+    Store_Instruction 3, "add"
+  End If
+  txtInfo.text = StoreCount
+End Sub
+
+Private Sub MSUB_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Store_Instruction 2, "sub"
+  ElseIf Shift = fmCtrlMask Then
+    Store_Instruction 1, "sub"
+  Else
+    Store_Instruction 3, "sub"
+  End If
+  txtInfo.text = StoreCount
+End Sub
+
+Private Sub MRLW_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Store_Instruction 2, "lw"
+  ElseIf Shift = fmCtrlMask Then
+    Store_Instruction 1, "lw"
+  Else
+    Store_Instruction 3, "lw"
+  End If
+  txtInfo.text = StoreCount
+End Sub
+
+Private Sub MZERO_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Store_Instruction 2, "zero"
+  ElseIf Shift = fmCtrlMask Then
+    Store_Instruction 1, "zero"
+  Else
+    Store_Instruction 3, "zero"
+  End If
+  txtInfo.text = StoreCount
+End Sub
+
+
+
 Private Sub CQLSameSize()
   ActiveDocument.Unit = cdrMillimeter
   Dim s As Shape
@@ -119,7 +176,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
@@ -139,7 +196,7 @@ Private Sub CQLSameOutlineColor()
   ' 查找对象
   r = colr.RGBRed
   G = colr.RGBGreen
-  B = colr.RGBBlue
+  b = colr.RGBBlue
   
   If OptBt.value = True Then
     ActiveDocument.ClearSelection
@@ -150,13 +207,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
@@ -175,7 +232,7 @@ Private Sub CQLSameUniformColor()
   ' 查找对象
   r = colr.RGBRed
   G = colr.RGBGreen
-  B = colr.RGBBlue
+  b = colr.RGBBlue
   
   If OptBt.value = True Then
     ActiveDocument.ClearSelection
@@ -186,15 +243,23 @@ 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:
   MsgBox "对象填充为空。"
 End Sub
+
+Private Sub X_EXIT_Click()
+  Unload Me    ' 关闭
+End Sub
+
+Private Sub Close_Icon_Click()
+  Unload Me    ' 关闭
+End Sub

UI/CorelVBA.bas

@@ -1,212 +0,0 @@
-VERSION 5.00
-Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CorelVBA 
-   Caption         =   "CorelVBA 中秋节版 By 蘭雅sRGB 2022"
-   ClientHeight    =   5415
-   ClientLeft      =   45
-   ClientTop       =   330
-   ClientWidth     =   7740
-   OleObjectBlob   =   "CorelVBA.frx":0000
-   StartUpPosition =   1  '所有者中心
-End
-Attribute VB_Name = "CorelVBA"
-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 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 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
-
-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&
-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
-End Sub
-
-Private Sub UserForm_Initialize()
-  Dim IStyle As Long
-  Dim hWnd As Long
-  
-  hWnd = FindWindow("ThunderDFrame", Me.Caption)
-
-  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
-
-  With Me
-  '  .StartUpPosition = 0
-  '  .Left = 500
-  '  .Top = 200
-    .Width = 385.5
-    .Height = 271.45
-  End With
-  
-  UIFile = Path & "GMS\262235.xyz\UI.jpg"
-  If API.ExistsFile_UseFso(UIFile) Then
-    UI.Picture = LoadPicture(UIFile)   '换UI图
-  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 Button Then
-    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)
-  If Button Then
-    Me.Left = Me.Left - mx + x
-    Me.Top = Me.Top - my + Y
-  End If
-End Sub
-
-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)
-
-  ' 定义图标坐标pos
-  Dim pos_x As Variant
-  Dim pos_y As Variant
-  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
-    物件角线
-  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(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
-    拼版角线
-  End If
-
-  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(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
-    CQL选择
-  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
-    Tools.尺寸取整
-  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
-    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)
-
-  ElseIf Abs(x - pos_x(3)) < 30 And Abs(Y - pos_y(2)) < 30 Then
-    If switch Then
-      switch = Not switch
-      Tools.傻瓜火车排列 0#
-    Else
-      switch = Not switch
-      Tools.傻瓜阶梯排列 0#
-    End If
-    
-  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
-    WebHelp "https://262235.xyz/index.php/tag/vba/"
-  End If
-
-End Sub
-
-Function WebHelp(url As String)
-Dim h As Long, r As Long
-h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
-r = ShellExecute(h, "", url, "", "", 1)
-End Function
-
-
-Private Sub 绘制矩形()
-  剪贴板尺寸建立矩形.start
-End Sub
-
-Private Sub 角线爬虫()
-  裁切线.SelectLine_to_Cropline
-End Sub
-
-Private Sub 矩形拼版()
-  拼版裁切线.arrange
-End Sub
-
-Private Sub 批量替换()
-  CorelVBA.Hide
-  Replace_UI.Show 0
-End Sub
-
-Private Sub 拼版标记()
-  自动中线色阶条.Auto_ColorMark
-End Sub
-
-Private Sub 拼版角线()
-  拼版裁切线.Cut_lines
-End Sub
-
-Private Sub 物件角线()
-  裁切线.start
-End Sub
-
-Private Sub 智能群组()
-  智能群组和查找.智能群组
-End Sub
-
-Private Sub CQL选择()
-  CorelVBA.Hide
-  CQL_FIND_UI.Show 0
-End Sub
-
-
-Private Sub 学习CorelVBA实验室()
-  CorelVBA.Hide
-  ' 调用语句
-  I = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
-End Sub

UI/Make_SIZE.bas

@@ -13,6 +13,8 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
+
 Private Sub UserForm_Initialize()
     With Tis
         .BackColor = RGB(0, 150, 255)
@@ -147,7 +149,7 @@ Private Sub 标注线段长()
             s.Copy
             Set sc = ActiveLayer.Paste
             sc.ConvertToCurves
-            sc.Curve.Nodes.All.BreakApart
+            sc.Curve.Nodes.all.BreakApart
             sc.BreakApart
             For Each s1 In ActiveSelection.Shapes
                 Set st1 = ActiveLayer.CreateArtisticText(0, 0, round(s1.Curve.Length, 0), , , , TextBox1.value)
@@ -200,7 +202,7 @@ Private Sub 选中标注字号增加()
     Optimization = True '优化启动
     If TextBox1.value > 0 Then
         TextBox1.value = TextBox1.value + 1
-        For Each s In ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ")
+        For Each s In ActiveSelection.Shapes.FindShapes(Query:="@type ='text:artistic' and @Name='Text' ")
             s.text.Story.size = s.text.Story.size + 1
         Next
     End If
@@ -213,7 +215,7 @@ Private Sub 选中标注字号减少()
     Optimization = True '优化启动
     If TextBox1.value > 0 Then
         TextBox1.value = TextBox1.value - 1
-        For Each s In ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ")
+        For Each s In ActiveSelection.Shapes.FindShapes(Query:="@type ='text:artistic' and @Name='Text' ")
             s.text.Story.size = s.text.Story.size - 1
         Next
     End If
@@ -225,7 +227,7 @@ Private Sub 选中标注字号()
     Dim s As Shape
     Optimization = True '优化启动
     If TextBox1.value > 0 Then
-        For Each s In ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ")
+        For Each s In ActiveSelection.Shapes.FindShapes(Query:="@type ='text:artistic' and @Name='Text' ")
             s.text.Story.size = TextBox1.value
         Next
     End If
@@ -235,11 +237,11 @@ End Sub
 
 Private Sub 删除标注()
     If ActiveSelection.Shapes.Count > 0 Then
-        ActiveSelection.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ").Delete
-        ActiveSelection.Shapes.FindShapes(query:="@Name='line' ").Delete
+        ActiveSelection.Shapes.FindShapes(Query:="@type ='text:artistic' and @Name='Text' ").Delete
+        ActiveSelection.Shapes.FindShapes(Query:="@Name='line' ").Delete
     Else
-        ActivePage.Shapes.FindShapes(query:="@type ='text:artistic' and @Name='Text' ").Delete
-        ActivePage.Shapes.FindShapes(query:="@Name='line' ").Delete
+        ActivePage.Shapes.FindShapes(Query:="@type ='text:artistic' and @Name='Text' ").Delete
+        ActivePage.Shapes.FindShapes(Query:="@Name='line' ").Delete
     End If
 End Sub
 

UI/PhotoForm.bas

@@ -14,6 +14,7 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
 Private Sub UserForm_Initialize()
     On Error Resume Next
     ComboBox1.AddItem "灰度"

UI/Replace_UI.bas

@@ -14,8 +14,6 @@ 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
@@ -37,7 +35,7 @@ Private Const WS_EX_DLGMODALFRAME = &H1&
 
 
 Private Sub Close_Icon_Click()
-  Unload Me    ' 关闭
+  Unload Me    '// 关闭
 End Sub
 
 Private Sub UserForm_Initialize()
@@ -63,35 +61,35 @@ 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
-    CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
+  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
+    API.WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
   
   Replace_UI.Hide
@@ -100,12 +98,14 @@ End Sub
 
 Private Sub image_replace()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  API.BeginOpt
+  
   Dim image_path As String
   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
@@ -117,33 +117,27 @@ 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
 
-    '// 代码操作结束恢复窗口刷新
-    ActiveDocument.EndCommandGroup
-    Application.Optimization = False
-    ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
 ErrorHandler:
-    MsgBox "请先复制图片的完整路径，本工具能自动替换图片!"
-    Application.Optimization = False
-    On Error Resume Next
+'//    MsgBox "请先复制图片的完整路径，本工具能自动替换图片!"
+  API.EndOpt
 End Sub
 
 Private Sub copy_shape_replace_resize()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  API.BeginOpt
 
   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
@@ -153,34 +147,28 @@ 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
 
-    '// 代码操作结束恢复窗口刷新
-    ActiveDocument.EndCommandGroup
-    Application.Optimization = False
-    ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
 ErrorHandler:
-    MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
-    Application.Optimization = False
-    On Error Resume Next
+'// MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
+  API.EndOpt
 End Sub
 
 
 Private Sub copy_shape_replace()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  API.BeginOpt
 
   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
@@ -190,19 +178,13 @@ 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
 
-    '// 代码操作结束恢复窗口刷新
-    ActiveDocument.EndCommandGroup
-    Application.Optimization = False
-    ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
 ErrorHandler:
-    MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
-    Application.Optimization = False
-    On Error Resume Next
+'// MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
+  API.EndOpt
 End Sub
 

UI/Toolbar.bas

@@ -14,6 +14,9 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
 #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
@@ -63,8 +66,8 @@ Private Sub MakeUserFormTransparent(frm As Object, Optional Color As Variant)
 End Sub
 
 Private Sub Change_UI_Close_Voice_Click()
-  Speak_Msg "修改UI图片更换界面  注册表关闭语音 详QQ群"
-  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
+  SaveSetting "LYVBA", "Settings", "SpeakHelp", "0"
+  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA工具 永久免费开源" & vbNewLine & "主题图片文件名ToolBar.jpg 安装包中有多套皮肤选用"
 End Sub
 
 Private Sub UserForm_Initialize()
@@ -82,8 +85,8 @@ Private Sub UserForm_Initialize()
   
 With Me
   .StartUpPosition = 0
-  .Left = Val(GetSetting("262235.xyz", "Settings", "Left", "400"))  ' 设置工具栏位置
-  .Top = Val(GetSetting("262235.xyz", "Settings", "Top", "55"))
+  .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400"))  ' 设置工具栏位置
+  .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55"))
   .Height = 30
   .Width = 336
 End With
@@ -94,15 +97,15 @@ 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")
+  Outline_Width.text = GetSetting("LYVBA", "Settings", "Outline_Width", "0.2")
   
-  UIFile = Path & "GMS\262235.xyz\ToolBar.jpg"
+  UIFile = Path & "GMS\LYVBA\ToolBar.jpg"
   If API.ExistsFile_UseFso(UIFile) Then
     UI.Picture = LoadPicture(UIFile)   '换UI图
     Set pic1 = LoadPicture(UIFile)
   End If
 
-  UIL = Path & "GMS\262235.xyz\ToolBar1.jpg"
+  UIL = Path & "GMS\LYVBA\ToolBar1.jpg"
   If API.ExistsFile_UseFso(UIL) Then
     Set pic2 = LoadPicture(UIL)
     UIL_Key = True
@@ -201,48 +204,59 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
       '// 暂时空
       
     ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 暂时空
+      '// 木头人智能群组，异形群组
+      autogroup("group", 1).CreateSelection
       
     ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
       '// CTRL扩展工具栏
       Me.Height = 30 + 45
       
+    ElseIf Abs(X - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      ' 文本转曲  参数 all=1 ，支持框选和图框剪裁内的文本
+      ' Tools.TextShape_ConvertToCurves 1
     End If
     Exit Sub
   End If
 
+
   '// 鼠标右键 扩展键按钮优先  收缩工具栏  标记范围框  居中页面 尺寸取整数  单色黑中线标记 扩展工具栏  排列工具  扩展工具栏收缩
   If Button = 2 Then
     If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 收缩工具栏
       Me.Width = 30: Me.Height = 30
       UI.Visible = False: LOGO.Visible = True
 
     ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      Tools.居中页面
+      '// 居中页面
+      Tools.Align_Page_Center
 
     ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 标记范围框
       Tools.Mark_Range_Box
 
     ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      Tools.尺寸取整
+      '// 批量设置物件尺寸整数
+      Tools.Size_to_Integer
     
-    ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      自动中线色阶条.Auto_ColorMark_K
-
     '//分分合合把几个功能按键合并到一起，定义到右键上
     ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      Tools.分分合合
+     '// Tools.分分合合
+
+    ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 自动中线色阶条 黑白
+      AutoColorMark.Auto_ColorMark_K
 
     ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      智能群组和查找.智能群组 API.Create_Tolerance
+     '// 智能群组
+      SmartGroup.Smart_Group API.Create_Tolerance
 
     ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
       '// 右键扩展工具栏
       Me.Height = 30 + 45
       
     ElseIf Abs(X - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 右键拆分线段
-      Tools.Split_Segment
+     '// 文本统计信息
+     Application.FrameWork.Automation.InvokeItem "bf3bd8fe-ca26-4fe0-91b0-3b5c99786fb6"
 
     ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
       '// 右键排列工具
@@ -259,25 +273,32 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   
   '// 鼠标左键 单击按钮功能  按工具栏上图标正常功能
   If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    裁切线.start
+   '// 裁切线: 批量物件裁切线
+    CutLines.Batch_CutLines
     
   ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    剪贴板尺寸建立矩形.start
+  '// 剪贴板尺寸建立矩形
+    ClipbRectangle.Build_Rectangle
     
   ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    裁切线.SelectLine_to_Cropline
+    '// 单线条转裁切线 - 放置到页面四边
+    CutLines.SelectLine_to_Cropline
     
   ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    拼版裁切线.arrange
+    '// 拼版.Arrange
+    Arrange.Arrange
     
   ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    拼版裁切线.Cut_lines
+    '// 拼版裁切线
+    CutLines.Draw_Lines
     
   ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    自动中线色阶条.Auto_ColorMark
+    '// 自动中线色阶条 彩色
+    AutoColorMark.Auto_ColorMark
     
   ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    智能群组和查找.智能群组
+   '// 智能群组 没容差
+    SmartGroup.Smart_Group
     
   ElseIf Abs(X - pos_x(7)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     CQL_FIND_UI.Show 0
@@ -286,7 +307,8 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
     Replace_UI.Show 0
     
   ElseIf Abs(X - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    Tools.TextShape_ConvertToCurves
+    ' 简单文本转曲
+    Tools.TextShape_ConvertToCurves 0
     
   ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     '// 扩展工具栏
@@ -306,8 +328,8 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
       LOGO.Visible = True
   
       ' 保存工具条位置 Left 和 Top
-      SaveSetting "262235.xyz", "Settings", "Left", Me.Left
-      SaveSetting "262235.xyz", "Settings", "Top", Me.Top
+      SaveSetting "LYVBA", "Settings", "Left", Me.Left
+      SaveSetting "LYVBA", "Settings", "Top", Me.Top
     
       Speak_Msg "左键缩小 右键收缩"
     End If
@@ -403,19 +425,20 @@ End Sub
 
 Private Sub OPEN_UI_BIG_Click()
   Unload Me
-  CorelVBA.Show 0
+  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA工具 永久免费开源" _
+       & vbNewLine & "源码网址:" & vbNewLine & "https://github.com/hongwenjun/corelvba"
 End Sub
 
 Private Sub Settings_Click()
   If 0 < Val(Bleed.text) * Val(Line_len.text) < 100 Then
-   SaveSetting "262235.xyz", "Settings", "Bleed", Bleed.text
-   SaveSetting "262235.xyz", "Settings", "Line_len", Line_len.text
-   SaveSetting "262235.xyz", "Settings", "Outline_Width", Outline_Width.text
+   SaveSetting "LYVBA", "Settings", "Bleed", Bleed.text
+   SaveSetting "LYVBA", "Settings", "Line_len", Line_len.text
+   SaveSetting "LYVBA", "Settings", "Outline_Width", Outline_Width.text
   End If
 
   ' 保存工具条位置 Left 和 Top
-  SaveSetting "262235.xyz", "Settings", "Left", Me.Left
-  SaveSetting "262235.xyz", "Settings", "Top", Me.Top
+  SaveSetting "LYVBA", "Settings", "Left", Me.Left
+  SaveSetting "LYVBA", "Settings", "Top", Me.Top
   
   Me.Height = 30
 End Sub

UI/UniteOne.bas

@@ -28,7 +28,7 @@ Option Explicit
  Dim LogoFile As String         'Logo
  
  Dim s(1 To 255) As Shape   '定义对象用于存放每页的群组
- Dim p As Page          '定义多页
+ Dim P As Page          '定义多页
  
 
 '**** 主程序  执行
@@ -41,21 +41,21 @@ Private Sub cmdRun_Click()
  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
+ 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
+  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
   
@@ -64,7 +64,7 @@ Private Sub cmdRun_Click()
   y_M = 0
   End If
   
- Next p
+ Next P
  
   ActiveDocument.EndCommandGroup
   Application.Optimization = False
@@ -84,21 +84,21 @@ Private Sub cmdRunX_Click()
  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
+ 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
+  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
   
@@ -107,7 +107,7 @@ Private Sub cmdRunX_Click()
   y_M = 0
   End If
   
- Next p
+ Next P
  
   ActiveDocument.EndCommandGroup
   Application.Optimization = False
@@ -124,11 +124,11 @@ Private Sub UserForm_Initialize()
  Dim s As Shape
 ActiveDocument.Unit = cdrMillimeter '本文档单位为mm
 
- For Each p In ActiveDocument.Pages
- iPages = p.index
+ For Each P In ActiveDocument.Pages
+ iPages = P.index
  If iPages = 1 Then
-  p.Activate
-  p.Shapes.All.CreateSelection
+  P.Activate
+  P.Shapes.all.CreateSelection
 
  Set s = ActiveDocument.Selection
         If s.Shapes.Count = 0 Then
@@ -137,7 +137,7 @@ ActiveDocument.Unit = cdrMillimeter '本文档单位为mm
         End If
  
  End If
- Next p
+ Next P
  
 
  txtLie.text = 5

UI/Woodman.bas

@@ -15,6 +15,7 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
+
 Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     ActiveDocument.BeginCommandGroup:  Application.Optimization = True
     Set os = ActiveSelectionRange
@@ -73,8 +74,12 @@ Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
         On Error Resume Next
         Set os = ActiveSelectionRange
         For Each s In os.Shapes
-            If s.Type = cdrLinearDimensionShape Then s.Delete
+            If s.Type = cdrLinearDimensionShape Then sr.Add s
         Next s
+          If sr.Count > 0 Then
+            os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
+            ActiveSelectionRange.Delete
+          End If
         On Error GoTo 0
     Else
         make_sizes Shift
@@ -122,13 +127,17 @@ Sub make_sizes_sep(dr, Optional shft = 0)
     
     Dim border As Variant
     Dim Line_len As Double
-    Line_len = API.GetSet("Line_len")
+    If shft > 1 Then
+        Line_len = API.Set_Space_Width   '// 设置文字空间间隙
+    Else
+        Line_len = API.Set_Space_Width(True)    '// 只读文字空间间隙
+    End If
     
-    border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + 10, os.TopY + 20 + Line_len, _
-                    cdrBottomRight, cdrTopRight, os.LeftX - 10, os.LeftX - 20 - Line_len)
+    border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + Line_len, os.TopY + 2 * Line_len, _
+                    cdrBottomRight, cdrTopRight, os.LeftX - Line_len, os.LeftX - 2 * Line_len)
                     
-    If chkOpposite.value Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - 10, os.BottomY - 20 - Line_len, _
-                            cdrBottomLeft, cdrTopLeft, os.RightX + 10, os.RightX + 20 + Line_len)
+    If chkOpposite.value Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - Line_len, os.BottomY - 2 * Line_len, _
+                            cdrBottomLeft, cdrTopLeft, os.RightX + Line_len, os.RightX + 2 * Line_len)
    
         
     If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then os.Sort "@shape1.left < @shape2.left"
@@ -355,8 +364,10 @@ ErrorHandler:
   MsgBox "s.Curve.AutoReduceNodes 只有高版本才支持本API"
 End Sub
 
-
-Private Sub MarkLines_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+'// 使用标记线批量建立尺寸标注
+Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignLeft, chkOpposite.value
     make_sizes_sep "lfbx", Shift
@@ -365,13 +376,15 @@ Private Sub MarkLines_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, B
     Label_Makesizes.Caption = "试试右键"
     make_sizes_sep "upbx", Shift
   End If
+  sr.CreateSelection
 End Sub
 
 Private Sub chkOpposite_Click()
 '  Debug.Print chkOpposite.value
 End Sub
 
-Private Sub manual_makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+'// 使用手工选节点建立尺寸标注，使用Ctrl分离尺寸标注
+Private Sub Manual_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
       '// 右键
   ElseIf Shift = fmCtrlMask Then
@@ -399,16 +412,24 @@ Private Function Untie_MarkLines()
   End If
 End Function
 
-
 '// 手动标注倾斜尺寸
 Private Function Slanted_Makesize()
   On Error GoTo ErrorHandler
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   Dim nr As NodeRange, cnt As Integer
+  Dim sr As ShapeRange
   Dim x1 As Double, y1 As Double
   Dim x2 As Double, y2 As Double
+  
+  Set sr = ActiveSelectionRange
   Set nr = ActiveShape.Curve.Selection
+  
+  If chkOpposite.value = False Then
+    Slanted_Sort_Make sr  '// 排序标注倾斜尺寸
+    Exit Function
+  End If
   If nr.Count < 2 Then Exit Function
+
   cnt = nr.Count
   While cnt > 1
     x1 = nr(cnt).PositionX
@@ -418,9 +439,46 @@ Private Function Slanted_Makesize()
     
     Set pts = CreateSnapPoint(x1, y1)
     Set pte = CreateSnapPoint(x2, y2)
-    ActiveLayer.CreateLinearDimension cdrDimensionSlanted, pts, pte, True, x1 - 5, y1 + 5, cdrDimensionStyleEngineering
+    ActiveLayer.CreateLinearDimension cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering
     cnt = cnt - 1
   Wend
+
 ErrorHandler:
+  API.EndOpt
+End Function
+
+'// 排序标注倾斜尺寸
+Private Function Slanted_Sort_Make(shs As ShapeRange)
+  Dim sr As New ShapeRange, sr_copy As New ShapeRange
+  Dim s As Shape, sh As Shape
+  Dim nr As NodeRange
+  For Each sh In shs
+    Set nr = sh.Curve.Selection
+    For Each n In nr
+      Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5)
+      sr.Add s
+    Next n
+  Next sh
+  
+  CutLines.RemoveDuplicates sr  '// 简单删除重复算法
+  
+  sr.Sort "@shape1.left < @shape2.left"
+  sr.CreateSelection
+  
+  Set sr_copy = ActiveSelectionRange
+'  Debug.Print sr_copy.Count
+  
+  For i = 1 To sr_copy.Count - 1
+    x1 = sr_copy(i + 1).CenterX
+    y1 = sr_copy(i + 1).CenterY
+    x2 = sr_copy(i).CenterX
+    y2 = sr_copy(i).CenterY
+    
+    Set pts = CreateSnapPoint(x1, y1)
+    Set pte = CreateSnapPoint(x2, y2)
+    ActiveLayer.CreateLinearDimension cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering
+  Next i
+  sr_copy.Delete
+  API.EndOpt
 End Function
 

UI/frmSelectSame.bas

@@ -1,7 +1,7 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmSelectSame 
-   Caption         =   "ÏàËÆÑ¡Ôñ"
-   ClientHeight    =   4770
+   Caption         =   "相似选择-魔改版 蘭雅"
+   ClientHeight    =   5775
    ClientLeft      =   495
    ClientTop       =   5895
    ClientWidth     =   2625
@@ -14,93 +14,63 @@ Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
-Option Explicit         'Requires explicit declaration of all
-                        'variables. This protects against
-                        'inadvertent use of the slow 'Variant' type
-                        'variables which are used when the specific
-                        'type is unknown.
-                        
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+'// Attribute VB_Name = "相似选择-魔改版 蘭雅"   frmSelectSame   2023.6.12
+
+Option Explicit
+'需�显�声明所有��。 这�以防止无�中使用缓慢的“Variant�类型��，这些��在特定类型未知时使用。
+'Requires explicit declaration of all variables. This protects against inadvertent use of the slow 'Variant' type variables which are used when the specific type is unknown.
+
+Public ssreg As ShapeRange
+
 Private Const TOOLNAME As String = "VBA_SelectSame"
 Private Const SECTION As String = "Options"
 
- Private Sub btnSelect_Click()
-    On Error Resume Next
+Private Sub btnSelect_Click()
+    If 0 = ActiveSelectionRange.Count Then Exit Sub
+    On Error GoTo ErrorHandler
+    
     Dim fLeft As Double, fTop As Double
     fLeft = frmSelectSame.Left
     fTop = frmSelectSame.Top
     SaveSetting "SelectSame", "Preferences", "form_left", fLeft
     SaveSetting "SelectSame", "Preferences", "form_top", fTop
-    beg
     
-    If (chkFill = False And _
-        chkOutline = False And _
-        chkOutlineColor = False And _
-        chkOutlineLength = False And _
-        chkSize = False And _
-        chkWHratio = False And _
-        chkType = False And _
-        chkNodes = False And _
-        chkSegments = False And _
-        chkPaths = False) Then
-            MsgBox "ÇëÖÁÉÙÑ¡ÔñÒ»¸öÑ¡Ïî", vbCritical, "JH Select Same 2"
-            Exit Sub
+    '// 区域范围选择，需�关闭刷新优化
+    If OptBt.value = False Then
+      API.BeginOpt
+    Else
+      add_ssreg
     End If
-            
-    With Me '"Me" is a VBA reserved word, returning a
-                        'reference to the form (or class module)
-                        'in which the current code is located.
-                        'The chk... functions return the current
-                        'Value of the check buttons of the same
-                        'name.
-        .SelectAllSimilar .chkFill, .chkOutline, .chkOutlineColor, .chkOutlineLength, _
-            .chkSize, .chkWHratio, .chkType, .chkNodes, .chkSegments, .chkPaths, _
-             .OptDoc, .Optpage, .Optlayer, .chkInGroups, .chkColorMark, .chkIndiv
+    
+    If (chkFill = False And chkOutline = False And chkOutlineColor = False And _
+      chkOutlineLength = False And chkSize = False And chkWHratio = False And _
+      chkType = False And chkNodes = False And chkSegments = False And _
+      chkPaths = False And chkFontName = False And chkFontSize = False And chkShapeName = False) Then
+        MsgBox "请至少选择一个选项", vbCritical, "Select Same"
+        GoTo ErrorHandler
+    End If
+
+
+'// "ME"是一个VBA�留字，返回对当�代�所在窗体（或类模�）的引用。 chk... 函数返回���选按钮的当�值。
+'// "ME" is a VBA reserved word, returning a reference to the form (or class module) in which the current code is located.
+'//  The chk... functions return the current Value of the check buttons of the same name.
+    With Me
+      .SelectAllSimilar .chkFill, .chkOutline, .chkOutlineColor, .chkOutlineLength, _
+      .chkSize, .chkWHratio, .chkType, .chkNodes, .chkSegments, .chkPaths, _
+      .OptDoc, .Optpage, .Optlayer, .chkInGroups, .chkColorMark, .chkIndiv, _
+      .chkFontName, .chkFontSize, .chkShapeName
     End With
     
-    EndOpt
+    API.EndOpt
     
-'Added to fix refresh issues
-ActiveWindow.Refresh
-Application.Refresh
-
-'On Error Resume Next
-'    If VersionMajor = 13 Then
-'        AppActivate "CorelDRAW X3"
-'        AppActivate ActiveDocument
-'    End If
-'    If VersionMajor = 14 Then
-'        AppActivate "CorelDRAW X4"
-'        AppActivate ActiveDocument
-'    End If
-'    If VersionMajor = 15 Then
-'        AppActivate "CorelDRAW X5"
-'        AppActivate ActiveDocument
-'    End If
-'    If VersionMajor = 16 Then
-'        AppActivate "CorelDRAW X6"
-'        AppActivate ActiveDocument
-'    End If
-'    If VersionMajor = 17 Then
-'        AppActivate "CorelDRAW X7"
-'        AppActivate ActiveDocument
-'    End If
-'        If VersionMajor = 18 Then
-'        AppActivate "CorelDRAW X8"
-'        AppActivate ActiveDocument
-'    End If
-'    If VersionMajor = 19 Then
-'        AppActivate "CorelDRAW 2017"
-'        AppActivate ActiveDocument
-'    End If
-'    If VersionMajor = 20 Then
-'        AppActivate "CorelDRAW 2018"
-'        AppActivate ActiveDocument
-'    End If
-'    If VersionMajor = 21 Then
-'        AppActivate "CorelDRAW 2019"
-'        AppActivate ActiveDocument
-'    End If
+Exit Sub
+ErrorHandler:
+  Application.Optimization = False
 End Sub
+
 Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
                     Optional CheckOutline As Boolean = True, _
                     Optional CheckOutlineColor As Boolean = True, _
@@ -116,45 +86,61 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
                     Optional WithinLayer As Boolean = False, _
                     Optional WithinGroups As Boolean = True, _
                     Optional CheckColorMark As Boolean = False, _
-                    Optional CheckIndiv As Boolean = True)
+                    Optional CheckIndiv As Boolean = True, _
+                    Optional CheckFontName As Boolean = False, _
+                    Optional CheckFontSize As Boolean = False, _
+                    Optional CheckShapeName As Boolean = False)
                     
     'Object variables.              Reference to:
     Dim shpsSelected As Shapes          'selected shapes,
-    Dim shpsToTest As Shapes            'full set of shapes to be tested,
+    Dim shpsToTest As Shapes            'full set of shapes to be tested,  ' 待测形状全部集�
     Dim pagesr As ShapeRange           'pages shapes collection,
     Dim docsr As New ShapeRange
     Dim shpModel As Shape               'a pre-selected shape,
     Dim shpToMatch As Shape             'a shape to be matched,
     'Dim oScript As Object               'CorelScript object,
-    Dim clnModelShapes As Collection    'our list of pre-selected shapes,¶¨ÒåÔ´¶ÔÏ󼯺Ï
-    Dim clnSubShapes As Collection      'our list of shapes inside a group. ¶¨ÒåȺ×éÄÚµÄÄ¿±ê¶ÔÏó
-    Dim P As Page, p1 As Page           'ÎĵµÖвéÕÒʹÓÃ
+    Dim clnModelShapes As Collection    'our list of pre-selected shapes,  '定义�对象集�
+    Dim clnSubShapes As Collection      'our list of shapes inside a group. '定义群组内的目标对象
+    Dim P As Page, p1 As Page           '文档中查找使用
     Dim shr As ShapeRange, sr As New ShapeRange
-    Dim i As Integer  ' 'ÎĵµÖÐÑ­»·²éÕÒ¼ÆÊýʹÓÃ
-                                            
+    Dim i As Integer  ' '文档中循环查找计数使用
+    Dim fsn As Shape  '// 扩展功能: 字体字�标记�检测�对象
+
     On Error GoTo NothingSelected       'Get a reference to any
     Set shr = ActiveSelectionRange
     Set shpsSelected = ActiveDocument.Selection.Shapes
-    On Error GoTo 0                     'pre-selected shapes. ½«ÎĵµÖе±Ç°Ñ¡Öеķ¶Î§×÷ΪԴ¶ÔÏó
+'    On Error GoTo 0                     'pre-selected shapes. 将文档中当�选中的范围作为�对象
     
     If shpsSelected.Count > 0 Then          'Gather the pre-selected shapes
         Set clnModelShapes = New Collection 'into a new collection for
-        For Each shpModel In shpsSelected   'simple processing. ½¨Á¢Ô´¶ÔÏ󼯺Ï
+        For Each shpModel In shpsSelected   'simple processing. 建立�对象集�
            clnModelShapes.Add shpModel
         Next
         
+
+        '// 魔改分支 字体-字�-标记�
+        If CheckFontName Or CheckFontSize Or CheckShapeName Then
+          Set fsn = shr(1)
+        End If
+
         '===================================
         ' TurnOptimizations cdrOptimizationOn
         '===================================
        
-        
         If WithinPage Then
+
+          If OptBt.value = True Then
+            Set shpsToTest = ssreg.Shapes
+            OptBt.value = 0
+            API.BeginOpt
+          Else
             Set shpsToTest = ActivePage.Shapes
+          End If
                                             'Ensure that "Edit across layers"
                                             'is ON. Otherwise, selecting
 '            Set oScript = CorelScript       'across layers, followed by
 '            oScript.SetMultiLayer True      'grouping, can flatten all
-'            Set oScript = Nothing           'layers into one. Ñ¡Öбíʾ½«¶Ôµ±Ç°Ò³ÃæµÄËùÓжÔÏóÓëÔ´¶ÔÏó½øÐÐÆ¥Å䣬·ñÔòֻƥÅ䵱ǰͼ²ãµÄ¶ÔÏó
+'            Set oScript = Nothing           'layers into one. 选中表示将对当�页�的所有对象与�对象进行匹�，�则�匹�当�图层的对象
  
             'Replace the above with this line, CoreScript is not longer support X7+
             ActiveDocument.EditAcrossLayers = True
@@ -163,18 +149,18 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
             Set shpsToTest = ActivePage.ActiveLayer.Shapes
         End If
         
-        If WithinDoc Then 'ÔÚµ±Ç°Îĵµ²éÕÒ£¬½«µ±Ç°Ò³ÃæÏàÓ¦µÄ¶ÔÏó¼ÓÈëµ½´ý±È½Ï·¶Î§
-            
-            'Set p1 = ActivePage
+        If WithinDoc Then '在当�文档查找，将当�页�相应的对象加入到待比较范围
             For i = 1 To ActiveDocument.Pages.Count
                 ActiveDocument.Pages(i).Activate
-                Set pagesr = ActivePage.SelectShapesFromRectangle(0, 2480, 1820, 0, False).Shapes.All
-                docsr.AddRange pagesr '¸÷Ò³ÃæÒÀ´Î²éÕÒ£¬ÏàÓ¦µÄ¶ÔÏó¼ÓÈëµ½´ý±È½Ï·¶Î§
+                Set p1 = ActiveDocument.Pages(i)
+                Set pagesr = ActivePage.SelectShapesFromRectangle(0, p1.CenterY * 2, p1.CenterX * 2, 0, False).Shapes.all
+                Debug.Print p1.CenterY * 2 & p1.CenterX * 2
+                docsr.AddRange pagesr '�页��次查找，相应的对象加入到待比较范围
                 
             Next i
             Set shpsToTest = docsr.Shapes
-'            MsgBox "¹²Óдý±È½Ï¶ÔÏó " & shpsToTest.Count & " ¸ö"
-            Label13.Caption = "¹²Óдý±È½Ï¶ÔÏó " & shpsToTest.Count & " ¸ö"
+'            MsgBox "共有待比较对象 " & shpsToTest.Count & " 个"
+            Label13.Caption = "共有待比较对象 " & shpsToTest.Count & " 个"
             'p1.Activate
         End If
         
@@ -207,7 +193,7 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
                         If ShapesMatch(shpToMatch, shpModel, CheckFill, _
                                 CheckOutline, CheckOutlineColor, CheckOutlineLength, CheckSize, CheckWHratio, _
                                 CheckType, CountNodes, CountSegments, CountPaths, CheckIndiv) Then
-                            'shpToMatch.AddToSelection
+                               'shpToMatch.AddToSelection
                             sr.Add shpToMatch
                             Exit For        'If a match has now been found,
                         End If              'we can skip any remaining models.
@@ -222,11 +208,19 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
         'CorelScript.RedrawScreen
         '===================================
         'sr.Add ActiveDocument.Selection
-        If CheckColorMark And sr.Count > 0 Then sr.SetOutlineProperties , , CreateCMYKColor(0, 100, 0, 0) 'ÂÖÀªÏßÉÏÉ«
+        If CheckColorMark And sr.Count > 0 Then sr.SetOutlineProperties , , CreateCMYKColor(0, 100, 0, 0) '轮廓线上色
         sr.AddRange shr
-        sr.CreateSelection
-'        MsgBox "¹²ÕÒµ½ " & sr.Count & " ¸ö¶ÔÏó"
-        Label13.Caption = "¹²ÕÒµ½ " & sr.Count & " ¸ö¶ÔÏó"
+    
+        '// 魔改分支 字体-字�-标记�
+        If CheckFontName Or CheckFontSize Or CheckShapeName Then
+          If CheckFontName Then ShapesMatch_Font_Name fsn, sr, "FontName"
+          If CheckFontSize Then ShapesMatch_Font_Name fsn, sr, "FontSize"
+          If CheckShapeName Then ShapesMatch_Font_Name fsn, sr, "ShapeName"
+        End If
+        
+       sr.CreateSelection
+        '// 显示找到对象
+        Label13.Caption = "共找到 " & sr.Count & " 个对象"
     End If
     
     Set clnModelShapes = Nothing               'Release the memory allocated
@@ -235,6 +229,48 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
 NothingSelected:
 End Sub
 
+'// 添加区域选择分支
+Private Function add_ssreg()
+    Dim ssr As ShapeRange, shr As ShapeRange
+    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
+    Dim Shift As Long
+    Dim b As Boolean
+    Set shr = ActiveSelectionRange
+    b = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
+    If Not b Then
+      Set ssreg = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, True).Shapes.all
+    End If
+    ActiveDocument.ClearSelection
+    shr.CreateSelection
+End Function
+
+'// 魔改分支 字体-字�-标记�  检查匹�
+Private Function ShapesMatch_Font_Name(ByVal fsn As Shape, sr As ShapeRange, Check_Case As String)
+  Dim xz As String, sh_name As String, strFontName As String
+  Dim FontSize As Double
+  Dim srText As ShapeRange
+  Set srText = sr.Shapes.FindShapes(Type:=cdrTextShape)
+      
+  Select Case Check_Case
+  Case "FontName"
+    If fsn.Type = cdrTextShape Then
+      strFontName = fsn.text.Story.Font
+      Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and @com.text.story.font = '" & strFontName & "'")
+    End If
+    
+  Case "FontSize"
+    If fsn.Type = cdrTextShape Then
+      FontSize = fsn.text.Story.size
+      Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and (@com.text.story.size - " & FontSize & ").abs() < 0.1 ")
+    End If
+    
+  Case "ShapeName"
+    sh_name = fsn.Name
+      Set sr = sr.Shapes.FindShapes(Query:="@name ='" & sh_name & "'")
+  End Select
+End Function
+
+
 Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
                     Optional CheckFill As Boolean = True, _
                     Optional CheckOutline As Boolean = True, _
@@ -249,23 +285,23 @@ Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
                     Optional CheckIndiv As Boolean = False) As Boolean
     
     'Sizes "match" if they differ by less than one per cent
-    Dim ToleranceSize As Double     'Ãæ»ý´óСÔÊÐí²¨¶¯
-    ToleranceSize = Me.TextBox1 / 100  'Ãæ»ý´óСÔÊÐí²¨¶¯,ÒÔ°Ù·Ö±ÈΪµ¥Î»
+    Dim ToleranceSize As Double     '�积大��许波动
+    ToleranceSize = Me.TextBox1 / 100  '�积大��许波动,以百分比为��
     
-    Dim ToleranceLength As Double   'Ïß³¤ÔÊÐí²¨¶¯
-    ToleranceLength = Me.TextBox2 / 100 '³¤¶ÈÔÊÐí²¨¶¯,ÒÔ°Ù·Ö±ÈΪµ¥Î»
+    Dim ToleranceLength As Double   '线长�许波动
+    ToleranceLength = Me.TextBox2 / 100 '长度�许波动,以百分比为��
     
-    Dim ToleranceNodesCount As Long  '½ÚµãÊýÁ¿ÔÊÐí²¨¶¯,ÒÔ µã µ¥Î»
-    ToleranceNodesCount = Me.TextBox3 '½ÚµãÊýÁ¿ÔÊÐí²¨¶¯,ÒÔ µã µ¥Î»
+    Dim ToleranceNodesCount As Long  '节点数��许波动,以 点 ��
+    ToleranceNodesCount = Me.TextBox3 '节点数��许波动,以 点 ��
     
-    Dim ToleranceSubPathsCount As Long  '×Ó·¾¶ ×ÓÏ߶ΠÔÊÐí²¨¶¯,ÒÔ Ìõ Ϊµ¥Î»
-    ToleranceSubPathsCount = Me.TextBox4 '×Ó·¾¶ ×ÓÏ߶ΠÔÊÐí²¨¶¯,ÒÔ Ìõ Ϊµ¥Î»
+    Dim ToleranceSubPathsCount As Long  '�路径 �线段 �许波动,以 � 为��
+    ToleranceSubPathsCount = Me.TextBox4 '�路径 �线段 �许波动,以 � 为��
     
-    Dim ToleranceWHratio As Double  '³¤¿í±È ÔÊÐí²¨¶¯,ÒÔ °Ù·Ö±È Ϊµ¥Î»
-    ToleranceWHratio = Me.TextBox5  '³¤¿í±È ÔÊÐí²¨¶¯,ÒÔ °Ù·Ö±È Ϊµ¥Î»
+    Dim ToleranceWHratio As Double  '长宽比 �许波动,以 百分比 为��
+    ToleranceWHratio = Me.TextBox5  '长宽比 �许波动,以 百分比 为��
     
-    Dim ToleranceSegmentsCount As Long  'Ï߶ÎÊý ÔÊÐí²¨¶¯,ÒÔ ¸ö Ϊµ¥Î»
-    ToleranceSegmentsCount = Me.TextBox6 'Ï߶ÎÊý ÔÊÐí²¨¶¯,ÒÔ ¸ö Ϊµ¥Î»
+    Dim ToleranceSegmentsCount As Long  '线段数 �许波动,以 个 为��
+    ToleranceSegmentsCount = Me.TextBox6 '线段数 �许波动,以 个 为��
         
     'Object Variables.        'Reference to:
     Dim clrModel As Color           'color features of model shape,
@@ -275,7 +311,7 @@ Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
     Dim crvModel As Curve           'Bezier curve of model shape,
     Dim crvShape As Curve           'Bezier curve of shape to be tested,
     Dim fntModel As StructFontProperties  'font properties of model text shape,
-    Dim trgModel As Text            'general text properties of model shape.
+    Dim trgModel As text            'general text properties of model shape.
     Dim spath As SubPath, opath As SubPath
     Dim j As Integer
     
@@ -326,7 +362,7 @@ Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
                 Set crvShape = .Curve
                 Set crvModel = shpModel.Curve
                 
-                'If CheckIndiv Then 'ÖðÌõ×Ó·¾¶±È½Ï
+                'If CheckIndiv Then '���路径比较
                     'If Abs(crvShape.SubPaths.Count - crvModel.SubPaths.Count) <> 0 Then GoTo NoMatch
                     'For j = 1 To crvShape.SubPaths.Count
                             'If Abs(crvShape.SubPath(j).Nodes.Count - crvModel.SubPath(j).Nodes.Count) > ToleranceNodesCount Then GoTo NoMatch
@@ -586,17 +622,14 @@ Private Function ShapesInGroup(GroupShape As Shape) As Collection
     End If                                  'collection is not needed
 End Function
 
-Private Sub Image2_Click()
-    frminfo.Show vbModeless
-End Sub
-
 Private Sub UserForm_Activate()
     Const YES As String = "True"
     Const NO As String = "False"
-   
-    Optpage = GetSetting(TOOLNAME, SECTION, "InPage", YES)
+
     OptDoc = GetSetting(TOOLNAME, SECTION, "InDoc", NO)
     Optlayer = GetSetting(TOOLNAME, SECTION, "InLayer", NO)
+    Optpage = GetSetting(TOOLNAME, SECTION, "InPage", YES)
+    
     chkColorMark = GetSetting(TOOLNAME, SECTION, "ColorMark", YES)
     chkFill = GetSetting(TOOLNAME, SECTION, "Fill", YES)
     chkInGroups = GetSetting(TOOLNAME, SECTION, "InGroups", YES)
@@ -678,15 +711,3 @@ End Sub
 Private Sub chkOutLineLength_Click()
     SaveSetting TOOLNAME, SECTION, "OutlineLength", CStr(chkOutlineLength)
 End Sub
-Sub beg()
-    ActiveDocument.Unit = cdrMillimeter
-    ActiveDocument.BeginCommandGroup "aa"
-    Optimization = True
-End Sub
-Sub EndOpt()
-    Optimization = False
-    ActiveDocument.EndCommandGroup
-    ActiveWindow.Refresh
-    Application.Refresh
-End Sub
-

donate.md

@@ -42,6 +42,8 @@ JZ捷众广告
 极速龙广告装饰图文快印②
 a-嘉盟
 幼儿园最亮的仔
+舞
+方华广告
 ```
 
 ### 会员群福利: 

module/API.bas

@@ -28,7 +28,7 @@ Public Function EndOpt()
 End Function
 
 Public Function Speak_Msg(message As String)
-  Speak_Help = Val(GetSetting("262235.xyz", "Settings", "SpeakHelp", "1"))
+  Speak_Help = Val(GetSetting("LYVBA", "Settings", "SpeakHelp", "0"))     '// 关停语音功能
   
   If Val(Speak_Help) = 1 Then
     Dim sapi
@@ -41,9 +41,9 @@ Public Function Speak_Msg(message As String)
 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"))
-  Outline_Width = Val(GetSetting("262235.xyz", "Settings", "Outline_Width", "0.2"))
+  Bleed = Val(GetSetting("LYVBA", "Settings", "Bleed", "2.0"))
+  Line_len = Val(GetSetting("LYVBA", "Settings", "Line_len", "3.0"))
+  Outline_Width = Val(GetSetting("LYVBA", "Settings", "Outline_Width", "0.2"))
 ' Debug.Print Bleed, Line_len, Outline_Width
 
   If s = "Bleed" Then
@@ -67,10 +67,14 @@ Public Function Create_Tolerance() As Double
   Create_Tolerance = Val(text)
 End Function
 
-Public Function Set_Space_Width() As Double
+Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As Double
   Dim text As String
   If GlobalUserData.Exists("SpaceWidth", 1) Then
     text = GlobalUserData("SpaceWidth", 1)
+    If OnlyRead Then
+      Set_Space_Width = Val(text)
+      Exit Function
+    End If
   End If
   text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
   If text = "" Then Exit Function
@@ -108,6 +112,15 @@ Public Function WriteClipBoard(ByVal s As String)
 #End If
 End Function
 
+'// 换行转空格 多个空格换成一个空格
+Public Function Newline_to_Space(ByVal Str As String) As String
+  Str = VBA.Replace(Str, Chr(13), " ")
+  Str = VBA.Replace(Str, Chr(9), " ")
+  Do While InStr(Str, "  ")
+      Str = VBA.Replace(Str, "  ", " ")
+  Loop
+  Newline_to_Space = Str
+End Function
 
 '// 获得数组元素个数
 Public Function arrlen(src As Variant) As Integer
@@ -133,11 +146,11 @@ End Function
 Public Function ArrayReverse(arr)
     Dim i As Integer, n As Integer
     n = UBound(arr)
-    Dim p(): ReDim p(n)
+    Dim P(): ReDim P(n)
     For i = 0 To n
-        p(i) = arr(n - i)
+        P(i) = arr(n - i)
     Next
-    ArrayReverse = p
+    ArrayReverse = P
 End Function
 
 '// 测试数组排序
@@ -156,25 +169,25 @@ End Function
 
 '// 两点连线的角度：返回角度(相对于X轴的角度)
 '// p为末点，O为始点
-Public Function alfaPP(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 '二点重合
+    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
+    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
+    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
+    ElseIf P(1) = o(1) And P(0) < o(0) Then
         beta = pi
-    ElseIf p(1) = o(1) And p(0) > o(0) Then
+    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 = 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
+        ElseIf P(1) < o(1) And P(0) < o(0) Then
             beta = -(pi + beta)
         End If
     End If
@@ -182,25 +195,25 @@ Public Function alfaPP(p, o)
 End Function
 
 '// 求过P点到线段AB上的垂足点(XY平面内的二维计算)
-Public Function pFootInXY(p, a, b)
+Public Function pFootInXY(P, a, b)
     If a(0) = b(0) Then
-        pFootInXY = Array(a(0), p(1), 0#): Exit Function
+        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
+        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)
+    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
+Public Function FindAllShapes() As ShapeRange
   Dim s As Shape
   Dim srPowerClipped As New ShapeRange
   Dim sr As ShapeRange, srAll As New ShapeRange
@@ -225,19 +238,21 @@ Function FindAllShapes() As ShapeRange
 End Function
 
 ' ************* 函数模块 ************* '
-Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
-
+Public Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
      Dim fso
-
      Set fso = CreateObject("Scripting.FileSystemObject")
-
      ExistsFile_UseFso = fso.FileExists(strPath)
-
      Set fso = Nothing
+End Function
 
+Public Function WebHelp(url As String)
+  Dim h As Long, r As Long
+  h = FindWindow(vbNullString, "Toolbar")
+  r = ShellExecute(h, "", url, "", "", 1)
 End Function
 
-Function test()
+
+Public Function test_sapi()
   Dim message, sapi
   MsgBox ("Please use the headset and listen to what I have to say...")
   message = "This is a simple voice test on your Microsoft Windows."

module/Arrange.bas

@@ -2,133 +2,12 @@ Attribute VB_Name = "Arrange"
 '// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 
-'// Attribute VB_Name = "拼版裁切线"   Arrange  2023.6.11
-
-Type Coordinate
-  X As Double
-  Y As Double
-End Type
-
-Sub Cut_lines()
-  If 0 = ActiveSelectionRange.Count Then Exit Sub
-  '// 代码运行时关闭窗口刷新
-  Application.Optimization = True
-  ActiveDocument.BeginCommandGroup  '一步撤消'
-  ActiveDocument.Unit = cdrMillimeter
-  Dim OrigSelection As ShapeRange
-  Set OrigSelection = ActiveSelectionRange
-  
-  Dim s1 As Shape, sbd As Shape
-  Dim dot As Coordinate
-  Dim arr As Variant, border As Variant
-  
-  ' 当前选择物件的范围边界
-  set_lx = OrigSelection.LeftX:   set_rx = OrigSelection.RightX
-  set_by = OrigSelection.BottomY: set_ty = OrigSelection.TopY
-  set_cx = OrigSelection.CenterX: set_cy = OrigSelection.CenterY
-  radius = 8
-  Bleed = API.GetSet("Bleed")
-  Line_len = API.GetSet("Line_len")
-  Outline_Width = API.GetSet("Outline_Width")
-  border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
-  
-  ' 创建边界矩形，用来添加角线
-  Set sbd = ActiveLayer.CreateRectangle(set_lx, set_by, set_rx, set_ty)
-  OrigSelection.Add sbd
-  
-  For Each Target In OrigSelection
-    Set s1 = Target
-    lx = s1.LeftX:   rx = s1.RightX
-    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) _
-      < 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)
-        
-        '// 范围边界坐标点判断
-        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
-    End If
-  Next Target
-  
-  sbd.Delete  '删除边界矩形
-  
-  '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
-  ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
-  ActiveSelection.group
-  ActiveSelection.Outline.SetProperties Outline_Width, Color:=CreateRegistrationColor
-  
-  ActiveDocument.EndCommandGroup
-  '// 代码操作结束恢复窗口刷新
-  Application.Optimization = False
-  ActiveWindow.Refresh
-  Application.Refresh
-End Sub
-
-'范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
-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))
-    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_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)
-    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)
-    set_line_color line
-  End If
-
-End Function
-
-'// 旧版本
-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))
-    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_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)
-    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)
-    set_line_color line
-  End If
-
-End Function
-
-Private Function set_line_color(line As Shape)
-   '// 设置轮廓线注册色
-  line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
-End Function
+'// Attribute VB_Name = "物件排列拼版"   Arrange  2023.6.11
 
 '// CorelDRAW 物件排列拼版简单代码
-Sub Arrange()
+Public Function Arrange()
   On Error GoTo ErrorHandler
+  API.BeginOpt
   ActiveDocument.Unit = cdrMillimeter
   row = 3     ' 拼版 3 x 4
   List = 4
@@ -142,12 +21,9 @@ Sub Arrange()
   Str = VBA.Replace(Str, "x", " ")
   Str = VBA.Replace(Str, "X", " ")
   Str = VBA.Replace(Str, "*", " ")
-  Str = VBA.Replace(Str, Chr(13), " ")
-  Str = VBA.Replace(Str, Chr(9), " ")
-  
-  Do While InStr(Str, "  ")    '多个空格换成一个空格
-      Str = VBA.Replace(Str, "  ", " ")
-  Loop
+
+  '// 换行转空格 多个空格换成一个空格
+  Str = API.Newline_to_Space(Str)
   
   arr = Split(Str)
 
@@ -161,7 +37,7 @@ Sub Arrange()
 
     If UBound(arr) > 2 Then
     row = Val(arr(2)):  List = Val(arr(3))
-      If row * List > 800 Then
+      If row * List > 8000 Then
         GoTo ErrorHandler
       ElseIf UBound(arr) > 3 Then
           sp = Val(arr(4))       '间隔
@@ -192,11 +68,8 @@ Sub Arrange()
   Dim dup2 As ShapeRange
   Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
        
-  Exit Sub
 ErrorHandler:
-  Speak_Msg "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
-  MsgBox "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
-  On Error Resume Next
-End Sub
+  API.EndOpt
+End Function
 
 

module/AutoColorMark.bas

@@ -5,14 +5,15 @@ Attribute VB_Name = "AutoColorMark"
 '// Attribute VB_Name = "自动中线色阶条"   AutoColorMark  2023.6.11
 
 '// 请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能
-Sub Auto_ColorMark()
-  If 0 = ActiveSelectionRange.Count Then Exit Sub
+Function Auto_ColorMark()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  Dim doc As Document: Set doc = ActiveDocument: doc.Unit = cdrMillimeter
+  API.BeginOpt
+
+  Dim doc As Document: Set doc = ActiveDocument
 
   ' 物件群组，设置页面大小
-  Call set_page_size
+  set_page_size
 
   '// 获得页面中心点 x,y
   px = ActiveDocument.ActivePage.CenterX
@@ -36,7 +37,7 @@ Sub Auto_ColorMark()
       put_target_line sh
 
   ElseIf "ColorStrip" = sh.ObjectData("MarkName").value Then
-      ColorStrip = Val(GetSetting("262235.xyz", "Settings", "ColorStrip", "1"))
+      ColorStrip = Val(GetSetting("LYVBA", "Settings", "ColorStrip", "1"))
       
       If Val(ColorStrip) = 1 Then
         put_ColorStrip sh   ' 放置彩色色阶条
@@ -66,26 +67,19 @@ Sub Auto_ColorMark()
   
   '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
   ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
-  ActiveSelection.group
+  ActiveSelection.Group
   ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
 
-  '// 代码操作结束恢复窗口刷新
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
 ErrorHandler:
-  MsgBox "请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能!"
-  Application.Optimization = False
-  On Error Resume Next
-End Sub
+  API.EndOpt
+End Function
 
-Private Sub set_page_size()
+Private Function set_page_size()
   ' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
   ActiveDocument.Unit = cdrMillimeter
   Dim OrigSelection As ShapeRange, sh As Shape
   Set OrigSelection = ActiveSelectionRange
-  Set sh = OrigSelection.group
+  Set sh = OrigSelection.Group
   
   ' MsgBox "选择物件尺寸: " & sh.SizeWidth & "x" & sh.SizeHeight
   ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
@@ -98,7 +92,7 @@ Private Sub set_page_size()
   sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
 #End If
 
-End Sub
+End Function
 
 Private Function set_line_color(line As Shape)
     '// 设置线宽和注册色
@@ -176,7 +170,7 @@ Private Function put_page_size()
   ' 添加文字 页面大小和文件名
   Dim st As Shape
   size = Trim(Str(Int(ActivePage.SizeWidth))) + "x" + Trim(Str(Int(ActivePage.SizeHeight))) + "mm"
-  size = size & " " & ActiveDocument.FileName & " " & Date '   & vbNewLine & "Https://262235.xyz 需要您的支持!"
+  size = size & " " & ActiveDocument.FileName & " " & Date '
   Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 7)
 End Function
 
@@ -252,14 +246,15 @@ End Function
 
 
 ' 自动中线 For 黑白产品版
-Sub Auto_ColorMark_K()
-  If 0 = ActiveSelectionRange.Count Then Exit Sub
+Function Auto_ColorMark_K()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  Dim doc As Document: Set doc = ActiveDocument: doc.Unit = cdrMillimeter
+  API.BeginOpt
+  
+  Dim doc As Document: Set doc = ActiveDocument
 
   ' 物件群组，设置页面大小
-  Call set_page_size
+  set_page_size
 
   '// 获得页面中心点 x,y
   px = ActiveDocument.ActivePage.CenterX
@@ -307,16 +302,9 @@ Sub Auto_ColorMark_K()
   
   '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
   ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
-  ActiveSelection.group
+  ActiveSelection.Group
   ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
 
-  '// 代码操作结束恢复窗口刷新
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-Exit Sub
 ErrorHandler:
-  MsgBox "请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能!"
-  Application.Optimization = False
-  On Error Resume Next
-End Sub
+  API.EndOpt
+End Function

module/CQLFindSame.bas

@@ -1,16 +1,13 @@
 Attribute VB_Name = "CQLFindSame"
-Sub 属性选择()
-  CQL_FIND_UI.Show 0
-End Sub
-
 Public Function CQLline_CM100()
-  On Error GoTo err
+  On Error GoTo ErrorHandler
+  API.BeginOpt
   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(3) = CreateRGBColor(0, 255, 0) ' RGB 绿
-  Set cm(4) = CreateRGBColor(255, 0, 0) ' RGB 红
+  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(3) = CreateRGBColor(0, 255, 0)        '// RGB ÂÌ
+  Set cm(4) = CreateRGBColor(255, 0, 0)        '// RGB ºì
 
   ActiveDocument.ClearSelection
   For i = 0 To 4
@@ -21,79 +18,7 @@ Public Function CQLline_CM100()
     ActivePage.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").AddToSelection
   Next i
 
-Exit Function
-err:
-  MsgBox "Function CQLline_CM100 错误!"
-End Function
-
-
-Sub 一键加点工具()
-  Dim OrigSelection As ShapeRange
-  Set OrigSelection = ActiveSelectionRange
-  If OrigSelection.Count <> 0 Then
-    OrigSelection.Copy
-  Else
-    MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
-    Exit Sub
-  End If
-  
-  ' 新建文件粘贴
-  Dim doc1 As Document
-  Set doc1 = CreateDocument
-  ActiveLayer.Paste
-  
-  ' 转曲线，一键加粗小红点
-  ActiveSelection.ConvertToCurves
-  Call get_little_points
-End Sub
-
-
-Private Sub get_little_points()
-  On Error GoTo ErrorHandler
-  '// 代码运行时关闭窗口刷新
-  Application.Optimization = True
-  ActiveDocument.BeginCommandGroup  '一步撤消'
-  
-  red_point_Size = 0.3
-  ActiveDocument.Unit = cdrMillimeter
-  Dim OrigSelection As ShapeRange, grp1 As ShapeRange, sh As Shape
-  Set OrigSelection = ActiveSelectionRange
-  Set grp1 = OrigSelection.UngroupAllEx
-  grp1.ApplyUniformFill CreateCMYKColor(50, 0, 0, 0)
-  
-  For Each sh In grp1
-    sh.BreakApartEx
-  Next sh
-  
-  ActiveDocument.ClearSelection
-  Dim sr As ShapeRange
-  Set sr = ActivePage.Shapes.FindShapes(Query:="@width < {" & red_point_Size & " mm} and @width > {0.1 mm} and @height <{" & red_point_Size & " mm} and @height >{0.1 mm}")
-  If sr.Count <> 0 Then
-    sr.CreateSelection
-    Set sh = ActiveSelection.group
-    sh.Outline.SetProperties 0.03, Color:=CreateCMYKColor(0, 100, 100, 0)
-    sr.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
-    sh.Move 0, 0.015
-    sh.Copy
-  Else
-    MsgBox "文件中小圆点足够大，不需要加粗!"
-  End If
-
-  ActivePage.Shapes.FindShapes(Query:="@colors.find(CMYK(50, 0, 0, 0))").CreateSelection
-  ActiveSelection.group
-  
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh
-  Application.Refresh
-  Exit Sub
 ErrorHandler:
-  MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
-  Application.Optimization = False
-  On Error Resume Next
-End Sub
-
-Sub 文字转曲()
-  Tools.TextShape_ConvertToCurves
-End Sub
+  API.EndOpt
+End Function
 

module/ClipbRectangle.bas

@@ -10,46 +10,45 @@ Type Coordinate
 End Type
 Public O_O As Coordinate
 
-Sub Start()
-    '// 坐标原点
-    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
-
-    '// 建立矩形 Width  x Height 单位 mm
-    Dim Str, arr, n
-    Str = API.GetClipBoardString
-
-    ' 替换 mm x * 换行 TAB 为空格
-    Str = VBA.Replace(Str, "m", " ")
-    Str = VBA.Replace(Str, "x", " ")
-    Str = VBA.Replace(Str, "X", " ")
-    Str = VBA.Replace(Str, "*", " ")
-    Str = VBA.Replace(Str, vbNewLine, " ")
-
-    Do While InStr(Str, "  ") '多个空格换成一个空格
-        Str = VBA.Replace(Str, "  ", " ")
-    Loop
-    arr = Split(Str)
-    
-    ActiveDocument.BeginCommandGroup  '一步撤消'
-    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))
-        
-        If X > 0 And Y > 0 Then
-            Rectangle X, Y
-            O_O.X = O_O.X + X + 30
-        End If
-    Next
-    ActiveDocument.EndCommandGroup
-End Sub
+Public Function Build_Rectangle()
+  '// 坐标原点
+  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
+  
+  '// 建立矩形 Width  x Height 单位 mm
+  Dim Str, arr, n
+  Str = API.GetClipBoardString
+  
+  '// 替换 mm x * 换行 TAB 为空格
+  Str = VBA.Replace(Str, "m", " ")
+  Str = VBA.Replace(Str, "x", " ")
+  Str = VBA.Replace(Str, "X", " ")
+  Str = VBA.Replace(Str, "*", " ")
+  Str = VBA.Replace(Str, vbNewLine, " ")
+  
+  Do While InStr(Str, "  ")     '// 多个空格换成一个空格
+      Str = VBA.Replace(Str, "  ", " ")
+  Loop
+  arr = Split(Str)
+  
+  API.BeginOpt
+  Dim X As Double
+  Dim Y As Double
+  For n = LBound(arr) To UBound(arr) - 1 Step 2
+      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
+      End If
+  Next
+  API.EndOpt
+End Function
 
 '// 建立矩形 Width  x Height 单位 mm
 Private Function Rectangle(Width As Double, Height As Double)
@@ -74,9 +73,8 @@ Private Function Rectangle(Width As Double, Height As Double)
   size.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
 End Function
 
-' 测试矩形变形
+'// 测试矩形变形
 Private Function setRectangle(Width As Double, Height As Double)
-
   Dim s1 As Shape
   Set s1 = ActiveSelection
   ActiveDocument.Unit = cdrMillimeter
@@ -91,9 +89,8 @@ Private Function setRectangle(Width As Double, Height As Double)
 
 End Function
 
-
 '// 获得选择物件大小信息
-Sub get_all_size()
+Public Function get_all_size()
   ActiveDocument.Unit = cdrMillimeter
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.CreateTextFile("R:\size.txt", True)
@@ -108,6 +105,6 @@ Sub get_all_size()
   f.Close
   MsgBox "输出物件尺寸信息到文件" & "R:\size.txt" & vbNewLine & s
   API.WriteClipBoard s
-End Sub
+End Function
 
 

module/CorelVBA窗口.bas

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

module/CutLines.bas

@@ -38,7 +38,7 @@ Public Function Batch_CutLines()
 
     '// 选中裁切线 群组 设置线宽和注册色
     ActiveDocument.AddToSelection s2, s3, s4, s5, s6, s7, s8, s9
-    ActiveSelection.group
+    ActiveSelection.Group
     sr.Add ActiveSelection
   Next s1
 
@@ -50,12 +50,6 @@ Public Function Batch_CutLines()
   API.EndOpt
 End Function
 
-
-Sub test_MarkLines()
-  Dimension_MarkLines cdrAlignLeft, True
-'  Dimension_MarkLines cdrAlignTop, True
-End Sub
-
 '// 标注尺寸标记线
 Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAlignTop, Optional ByVal mirror As Boolean = False)
   If 0 = ActiveSelectionRange.Count Then Exit Function
@@ -97,6 +91,7 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
   
   '// 页面边缘对齐
   For Each s In sr
+    s.Name = "DMKLine"
     If mark = cdrAlignTop Then
       s.TopY = py + Line_len + Bleed
     Else
@@ -123,8 +118,8 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
   API.EndOpt
 End Function
 
- '// 简单删除重复线算法
-Private Function RemoveDuplicates(sr As ShapeRange)
+ '// 简单删除重复线和物件算法算法
+Public Function RemoveDuplicates(sr As ShapeRange)
   Dim s As Shape, cnt As Integer, rms As New ShapeRange
   cnt = 1
   
@@ -138,7 +133,6 @@ Private Function RemoveDuplicates(sr As ShapeRange)
     If cnt > 1 Then
       If Check_duplicate(sr(cnt - 1), sr(cnt)) Then rms.Add sr(cnt)
     End If
-    s.Name = "DMKLine"
     cnt = cnt + 1
   Next s
   
@@ -148,7 +142,7 @@ End Function
  '// 检查重复算法
 Private Function Check_duplicate(s1 As Shape, s2 As Shape) As Boolean
   Check_duplicate = False
-  Jitter = 0.1
+  Jitter = 0.3
   X = Abs(s1.CenterX - s2.CenterX)
   Y = Abs(s1.CenterY - s2.CenterY)
   w = Abs(s1.SizeWidth - s2.SizeWidth)
@@ -221,3 +215,101 @@ Public Function SelectLine_to_Cropline()
   ActiveWindow.Refresh
   Application.Refresh
 End Function
+
+
+'// 拼版裁切线
+Public Function Draw_Lines()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  API.BeginOpt
+  
+  Dim OrigSelection As ShapeRange, sr As ShapeRange
+  Set OrigSelection = ActiveSelectionRange
+  Dim s1 As Shape, sbd As Shape
+  Dim dot As Coordinate
+  Dim arr As Variant, border As Variant
+  
+  ' 当前选择物件的范围边界
+  set_lx = OrigSelection.LeftX:   set_rx = OrigSelection.RightX
+  set_by = OrigSelection.BottomY: set_ty = OrigSelection.TopY
+  set_cx = OrigSelection.CenterX: set_cy = OrigSelection.CenterY
+  radius = 8
+  Bleed = API.GetSet("Bleed")
+  Line_len = API.GetSet("Line_len")
+  Outline_Width = API.GetSet("Outline_Width")
+  border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
+  
+  ' 创建边界矩形，用来添加角线
+  Set sbd = ActiveLayer.CreateRectangle(set_lx, set_by, set_rx, set_ty)
+  OrigSelection.Add sbd
+  
+  For Each Target In OrigSelection
+    Set s1 = Target
+    lx = s1.LeftX:   rx = s1.RightX
+    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) _
+      < 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)
+        
+        '// 范围边界坐标点判断
+        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
+    End If
+  Next Target
+  
+  sbd.Delete  '删除边界矩形
+  
+  '// 使用CQL 颜色标志查
+  Set sr = ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))")
+  
+  '// 简单删除重复
+  RemoveDuplicates sr
+  
+  '// 设置线宽和颜色，再选择
+   sr.SetOutlineProperties Outline_Width, Color:=CreateRegistrationColor
+   sr.Group
+   sr.AddRange OrigSelection
+   sr.AddToSelection
+
+  API.EndOpt
+End Function
+
+'范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
+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))
+    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_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)
+    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)
+    set_line_color line
+  End If
+
+End Function
+
+Private Function set_line_color(line As Shape)
+   '// 设置轮廓线注册色
+  line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
+End Function
+
+

module/Launcher.bas

@@ -2,53 +2,63 @@ Attribute VB_Name = "Launcher"
 '// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 
-'// Attribute VB_Name = "ÆäËû¹¤¾ßÆô¶¯"   Other Tools Start  2023.6.11
+'// Attribute VB_Name = "其他工具�动"   Other Tools Start  2023.6.11
 
 
-'// ÔËÐмÆËãÆ÷
+'// �行计算器
 Public Function START_Calc()
     Shell "Calc"
 End Function
 
 
-'// ¼Çʱ¾´ò¿ª±¸Íü¼
+'// 记事本打开备忘录
 Public Function START_Notepad()
-    cmd_line = "Notepad  C:\TSP\±¸Íü¼.txt"
-    Shell cmd_line, vbNormalNoFocus
+  On Error GoTo ErrorHandler
+  cmd_line = "Notepad  C:\TSP\备忘录.txt"
+  Shell cmd_line, vbNormalNoFocus
+ErrorHandler:
 End Function
 
 
-'// ´ò¿ªÌõÂëÔĶÁÆ÷
+'// 打开��阅读器
 Public Function START_Barcode_ImageReader()
-    cmd_line = "C:\Program Files (x86)\Softek Software\Softek Barcode Toolkit 30 Day Evaluation\bin\ImageReader.exe"
-    Shell cmd_line, vbNormalNoFocus
+  On Error GoTo ErrorHandler
+  cmd_line = "C:\Program Files (x86)\Softek Software\Softek Barcode Toolkit 30 Day Evaluation\bin\ImageReader.exe"
+  Shell cmd_line, vbNormalNoFocus
+ErrorHandler:
 End Function
 
 
-'// ʸÁ¿»¯¹¤¾ß Vector Magic
+'// 矢�化工具 Vector Magic
 Public Function START_Vector_Magic()
-    cmd_line = "C:\Program Files (x86)\Vector Magic\vmde.exe"
-    Shell cmd_line, vbNormalNoFocus
+  On Error GoTo ErrorHandler
+  cmd_line = "C:\Program Files (x86)\Vector Magic\vmde.exe"
+  Shell cmd_line, vbNormalNoFocus
+ErrorHandler:
 End Function
 
-'// waifu2x ͼƬ·Å´ó
+'// waifu2x 图片放大
 Public Function START_waifu2x()
-    cmd_line = "C:\soft\waifu2x-gui-1.2\waifu2x-gui.exe"
-    Shell cmd_line, vbNormalNoFocus
+  On Error GoTo ErrorHandler
+  cmd_line = "C:\soft\waifu2x-gui-1.2\waifu2x-gui.exe"
+  Shell cmd_line, vbNormalNoFocus
+ErrorHandler:
 End Function
 
-'// ¿ªÊ¼ÊÓƵ¼ÖÆ
+'// 开始视频录制
 Public Function START_Bandicam()
-    cmd_line = "C:\Program Files (x86)\Bandicam\BandicamPortable.exe"
-    Shell cmd_line, vbNormalNoFocus
+  On Error GoTo ErrorHandler
+  cmd_line = "C:\Program Files (x86)\Bandicam\BandicamPortable.exe"
+  Shell cmd_line, vbNormalNoFocus
+ErrorHandler:
 End Function
 
-'// ÕÒ×ÖÌå https://www.myfonts.com/pages/whatthefont
+'// 找字体 https://www.myfonts.com/pages/whatthefont
 Public Function START_whatthefont()
-    Weburl "https://www.myfonts.com/pages/whatthefont"
+  Weburl "https://www.myfonts.com/pages/whatthefont"
 End Function
 
 
 Function Weburl(url As String)
-  CorelVBA.WebHelp url
+  API.WebHelp url
 End Function

module/SmartGroup.bas

@@ -4,11 +4,8 @@ Attribute VB_Name = "SmartGroup"
 
 '// Attribute VB_Name = "智能群组"   SmartGroup  2023.6.11
 
-Sub 剪贴板物件替换()
-  Replace_UI.Show 0
-End Sub
 
-Public Sub 智能群组(Optional ByVal tr As Double = 0)
+Public Sub Smart_Group(Optional ByVal tr As Double = 0)
   If 0 = ActiveSelectionRange.Count Then Exit Sub
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
@@ -54,7 +51,7 @@ Public Sub 智能群组(Optional ByVal tr As Double = 0)
   '// 矩形边界智能群组，删除矩形
   For Each s In brk1
     Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
-    sh.Shapes.all.group
+    sh.Shapes.all.Group
     s.Delete
   Next
 
@@ -70,10 +67,8 @@ ErrorHandler:
 
 End Sub
 
-' 智能群组_V1 第一版，储备示例代码
-Function 智能群组_V1()
-  On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+'// 智能群组 原理版
+Function Smart_Group_ABC()
   ActiveDocument.Unit = cdrMillimeter
   
   Dim OrigSelection As ShapeRange, brk1 As ShapeRange
@@ -81,28 +76,14 @@ Function 智能群组_V1()
   Dim s1 As Shape, sh As Shape, s As Shape
   
   Set s1 = OrigSelection.CustomCommand("Boundary", "CreateBoundary")
-' s1.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
   Set brk1 = s1.BreakApartEx
 
   For Each s In brk1
     If s.SizeHeight > 10 Then
       Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
-      sh.Shapes.all.group
+      sh.Shapes.all.Group
     End If
     s.Delete
   Next
-  
-' ActiveDocument.ClearSelection
-' ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelections
-
-  '// 代码操作结束恢复窗口刷新
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-Exit Function
-ErrorHandler:
-  Application.Optimization = False
-  MsgBox "请先选择一些物件来确定群组范围!"
-  On Error Resume Next
 End Function
 

module/StoreSelect.bas

@@ -0,0 +1,43 @@
+Attribute VB_Name = "StoreSelect"
+Private sr_mem(3) As New ShapeRange
+Public StoreCount As String
+
+Public Function Store_Instruction(id As Integer, INST As String) As String
+  On Error GoTo ErrorHandler
+  API.BeginOpt "Undo MRC"
+  '// 选择指令执行
+  Case_Select_Range id, INST
+  
+  StoreCount = "Store Count: A->" & sr_mem(1).Count & "  B->" & sr_mem(2).Count & "  C->" & sr_mem(3).Count
+  API.EndOpt
+  
+Exit Function
+
+ErrorHandler:
+  Application.Optimization = False
+End Function
+
+Private Function Case_Select_Range(id As Integer, INST As String)
+  On Error GoTo ErrorHandler
+  Select Case INST
+    Case "add"
+      sr_mem(id).AddRange ActiveSelectionRange
+    Case "sub"
+      sr_mem(id).RemoveRange ActiveSelectionRange
+    Case "lw"
+     '// ActiveDocument.ClearSelection
+      sr_mem(id).AddToSelection
+    Case "zero"
+      If id = 3 Then
+        sr_mem(3).RemoveAll: sr_mem(1).RemoveAll: sr_mem(2).RemoveAll
+      Else
+        sr_mem(id).RemoveAll
+    End If
+
+  End Select
+  
+Exit Function
+
+ErrorHandler:
+  Application.Optimization = False
+End Function

module/TSP.bas

@@ -1,10 +1,10 @@
 Attribute VB_Name = "TSP"
 '// 导出节点信息到数据文件
 Public Function CDR_TO_TSP()
+  API.BeginOpt
   Set fs = CreateObject("Scripting.FileSystemObject")
   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
   Set shs = ActiveSelection.Shapes
@@ -19,13 +19,14 @@ Public Function CDR_TO_TSP()
   
   f.WriteLine TSP
   f.Close
-  MsgBox "小圆点导出节点信息到数据文件!" & vbNewLine
+'//  MsgBox "小圆点导出节点信息到数据文件!" & vbNewLine
+  API.EndOpt
 End Function
 
 '// 导出节点信息到数据文件
 Public Function Nodes_To_TSP()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  API.BeginOpt
   
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
@@ -53,38 +54,32 @@ Public Function Nodes_To_TSP()
   f.WriteLine TSP
   f.Close
   s.Delete
-  MsgBox "选择物件导出节点信息到数据文件!" & vbNewLine
+'//   MsgBox "选择物件导出节点信息到数据文件!" & vbNewLine
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 '// 运行CDR2TSP.exe
 Public Function START_TSP()
-    cmd_line = "C:\TSP\CDR2TSP.exe C:\TSP\CDR_TO_TSP"
-    Shell cmd_line
+  On Error GoTo ErrorHandler
+  cmd_line = "C:\TSP\CDR2TSP.exe C:\TSP\CDR_TO_TSP"
+  Shell cmd_line
+  
+ErrorHandler:
 End Function
 
 '//  TSP功能画线-连贯线
 Public Function TSP_TO_DRAW_LINE()
   On Error GoTo ErrorHandler
-  ActiveDocument.Unit = cdrMillimeter
-  
+  API.BeginOpt
+
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.OpenTextFile("C:\TSP\TSP.txt", 1, False)
   Dim Str, arr, n
   Str = f.ReadAll()
   
-  Str = VBA.Replace(Str, vbNewLine, " ")
-  Do While InStr(Str, "  ")
-      Str = VBA.Replace(Str, "  ", " ")
-  Loop
-  
+  Str = API.Newline_to_Space(Str)
   arr = Split(Str)
   total = Val(arr(0))
   
@@ -112,7 +107,7 @@ Public Function TSP_TO_DRAW_LINE()
   ActiveLayer.CreateCurve crv
   
 ErrorHandler:
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 '// 设置线条标记(颜色)
@@ -124,8 +119,7 @@ End Function
 '//  TSP功能画线-多线段
 Public Function TSP_TO_DRAW_LINES()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup: Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
@@ -133,10 +127,7 @@ Public Function TSP_TO_DRAW_LINES()
   Dim line As Shape
   Str = f.ReadAll()
   
-  Str = VBA.Replace(Str, vbNewLine, " ")
-  Do While InStr(Str, "  ")
-    Str = VBA.Replace(Str, "  ", " ")
-  Loop
+  Str = API.Newline_to_Space(Str)
   
   arr = Split(Str)
   For n = 2 To UBound(arr) - 1 Step 4
@@ -150,28 +141,26 @@ Public Function TSP_TO_DRAW_LINES()
   Next
   
   ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
-  ActiveSelection.group
+  ActiveSelection.Group
   ActiveSelection.Outline.SetProperties 0.2, Color:=CreateCMYKColor(0, 100, 100, 0)
   
-  ActiveDocument.EndCommandGroup: Application.Optimization = False
-  ActiveWindow.Refresh: Application.Refresh
-Exit Function
 ErrorHandler:
-    Application.Optimization = False
-    On Error Resume Next
+  API.EndOpt
 End Function
 
 '// 运行 TSP.exe
 Public Function MAKE_TSP()
-    cmd_line = "C:\TSP\TSP.exe"
-    Shell cmd_line
+  On Error GoTo ErrorHandler
+  cmd_line = "C:\TSP\TSP.exe"
+  Shell cmd_line
+ErrorHandler:
 End Function
 
 '// 位图制作小圆点
 Public Function BITMAP_MAKE_DOTS()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup: Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
+  
   Dim line, art, n, h, w
   Dim X As Double
   Dim Y As Double
@@ -189,7 +178,7 @@ Public Function BITMAP_MAKE_DOTS()
   h = Val(arr(0)): w = Val(arr(1))
   
   If h * w > 20000 Then
-      MsgBox "位图转换后的小圆点数量比较多:" & vbNewLine & h & " x " & w & " = " & h * w
+'//      MsgBox "位图转换后的小圆点数量比较多:" & vbNewLine & h & " x " & w & " = " & h * w
       flag = 1
   End If
 
@@ -208,18 +197,13 @@ Public Function BITMAP_MAKE_DOTS()
     Next n
   Next i
 
-  ActiveDocument.EndCommandGroup: Application.Optimization = False
-  ActiveWindow.Refresh: Application.Refresh
-Exit Function
 ErrorHandler:
-    Application.Optimization = False
-    On Error Resume Next
+  API.EndOpt
 End Function
 
 '// 坐标绘制圆点
 Private Function make_dots(X As Double, Y As Double)
-  Dim s As Shape
-  Dim c As Variant
+  Dim s As Shape, c As Variant
   c = Array(0, 255, 0)
   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))

module/Tools.bas

@@ -1,24 +1,10 @@
 Attribute VB_Name = "Tools"
-Public Function 分分合合()
-  拼版裁切线.Arrange
-  
-  CQL查找相同.CQLline_CM100
-  
-  拼版裁切线.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)
-  
-  自动中线色阶条.Auto_ColorMark
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
 
-End Function
-
-ActiveDocument.ReferencePoint = cdrTopLeft
-Public Function 傻瓜火车排列(space_width As Double)
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+'// 简易火车排列
+Public Function Simple_Train_Arrangement(Space_Width As Double)
+  API.BeginOpt
   Dim ssr As ShapeRange, s As Shape
   Dim cnt As Integer
   Set ssr = ActiveSelectionRange
@@ -33,21 +19,19 @@ Public Function 傻瓜火车排列(space_width As Double)
 
   ActiveDocument.ReferencePoint = cdrTopLeft
   For Each s In ssr
-    '' 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
-    '' 改成顶对齐 2022-08-10
+    '// 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
+    '// 改成顶对齐 2022-08-10
     ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + space_width, ssr(cnt - 1).TopY
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).TopY
     cnt = cnt + 1
   Next s
 
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
+  API.EndOpt
 End Function
 
-
-Public Function 傻瓜阶梯排列(space_width As Double)
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+'// 简易阶梯排列
+Public Function Simple_Ladder_Arrangement(Space_Width As Double)
+  API.BeginOpt
   Dim ssr As ShapeRange, s As Shape
   Dim cnt As Integer
   Set ssr = ActiveSelectionRange
@@ -62,19 +46,17 @@ Public Function 傻瓜阶梯排列(space_width As Double)
 
   ActiveDocument.ReferencePoint = cdrTopLeft
   For Each s In ssr
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - space_width
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - Space_Width
     cnt = cnt + 1
   Next s
 
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
+  API.EndOpt
 End Function
 
 '// 文本转曲线   默认使用简单转曲，参数 all=1 ，支持框选和图框剪裁内的文本
 Public Function TextShape_ConvertToCurves(Optional all = 0)
+  API.BeginOpt
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   Dim s As Shape, cnt As Long
   
   If all = 1 Then
@@ -89,19 +71,11 @@ Public Function TextShape_ConvertToCurves(Optional all = 0)
       cnt = cnt + 1
     Next s
   End If
-  
-  MsgBox "转曲物件统计: " & cnt, , "文本转曲线"
-  
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-  Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
-'' 复制物件
+'// 复制物件
 Public Function copy_shape()
   Dim OrigSelection As ShapeRange
   Set OrigSelection = ActiveSelectionRange
@@ -109,10 +83,9 @@ Public Function copy_shape()
 
 End Function
 
-'' 旋转物件角度
+'// 旋转物件角度
 Public Function Rotate_Shapes(n As Double)
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   
   Dim sh As Shape, shs As Shapes
   Set shs = ActiveSelection.Shapes
@@ -121,12 +94,10 @@ Public Function Rotate_Shapes(n As Double)
     sh.Rotate n
   Next sh
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
+  API.EndOpt
 End Function
 
-'' 得到物件尺寸
+'// 得到物件尺寸
 Public Function get_shape_size(ByRef sx As Double, ByRef sy As Double)
   ActiveDocument.Unit = cdrMillimeter
   Dim sh As ShapeRange
@@ -137,10 +108,9 @@ Public Function get_shape_size(ByRef sx As Double, ByRef sy As Double)
   sy = Int(sy * 100 + 0.5) / 100
 End Function
 
-'' 批量设置物件尺寸
+'// 批量设置物件尺寸
 Public Function Set_Shapes_size(ByRef sx As Double, ByRef sy As Double)
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   ActiveDocument.ReferencePoint = cdrCenter
   
   Dim sh As Shape, shs As Shapes
@@ -151,15 +121,14 @@ Public Function Set_Shapes_size(ByRef sx As Double, ByRef sy As Double)
      sh.SizeHeight = sy
   Next sh
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
+  API.EndOpt
 End Function
 
-Public Function 尺寸取整()
+'// 批量设置物件尺寸整数
+Public Function Size_to_Integer()
   If 0 = ActiveSelectionRange.Count Then Exit Function
-  ActiveDocument.Unit = cdrMillimeter
-  ' 修改变形尺寸基准
+  API.BeginOpt
+  '// 修改变形尺寸基准
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes
   Set shs = ActiveSelection.Shapes
@@ -171,18 +140,20 @@ Public Function 尺寸取整()
     s = s & size & vbNewLine
   Next sh
 
-  MsgBox "物件尺寸信息到剪贴板" & vbNewLine & s & vbNewLine
   API.WriteClipBoard s
+  API.EndOpt
 
+  MsgBox "Object Size Information To Clipboard:" & vbNewLine & s & vbNewLine
 End Function
 
-Public Function 居中页面()
+'// 设置物件页面居中
+Public Function Align_Page_Center()
   If 0 = ActiveSelectionRange.Count Then Exit Function
-  ' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
+  '// 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
   ActiveDocument.Unit = cdrMillimeter
   Dim OrigSelection As ShapeRange, sh As Shape
   Set OrigSelection = ActiveSelectionRange
-  Set sh = OrigSelection.group
+  Set sh = OrigSelection.Group
   ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
   
 #If VBA7 Then
@@ -197,39 +168,49 @@ End Function
 
 '''///  使用Python脚本 整理尺寸 提取条码数字 建立二维码 位图转文本 ///'''
 Public Function Python_Organize_Size()
-    mypy = Path & "GMS\262235.xyz\Organize_Size.py"
-    cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
-    Shell cmd_line
+  On Error GoTo ErrorHandler
+  mypy = Path & "GMS\LYVBA\Organize_Size.py"
+  cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
+  Shell cmd_line
+ErrorHandler:
 End Function
 
 Public Function Python_Get_Barcode_Number()
-    mypy = Path & "GMS\262235.xyz\Get_Barcode_Number.py"
-    cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
-    Shell cmd_line
+  On Error GoTo ErrorHandler
+  mypy = Path & "GMS\LYVBA\Get_Barcode_Number.py"
+  cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
+  Shell cmd_line
+ErrorHandler:
 End Function
 
 Public Function Python_BITMAP()
-    mypy = Path & "GMS\262235.xyz\BITMAP.py"
-    cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
-    Shell cmd_line
+  On Error GoTo ErrorHandler
+  mypy = Path & "GMS\LYVBA\BITMAP.py"
+  cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
+  Shell cmd_line
+ErrorHandler:
 End Function
 
 Public Function Python_BITMAP2()
-    Bitmap = "C:\TSP\BITMAP.exe"
-    Shell Bitmap
+  On Error GoTo ErrorHandler
+  Bitmap = "C:\TSP\BITMAP.exe"
+  Shell Bitmap
+ErrorHandler:
 End Function
 
 
 Public Function Python_Make_QRCode()
-    mypy = Path & "GMS\262235.xyz\Make_QRCode.py"
-    cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
-    Shell cmd_line
+  On Error GoTo ErrorHandler
+  mypy = Path & "GMS\LYVBA\Make_QRCode.py"
+  cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
+  Shell cmd_line
+ErrorHandler:
 End Function
 
-'' QRCode二维码制作
+'// QRCode二维码制作
 Public Function QRCode_replace()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  API.BeginOpt
   Dim image_path As String
   image_path = API.GetClipBoardString
   ActiveDocument.ReferencePoint = cdrCenter
@@ -255,17 +236,11 @@ Public Function QRCode_replace()
     
   Next sh
   
-    '// 代码操作结束恢复窗口刷新
-    ActiveDocument.EndCommandGroup
-    Application.Optimization = False
-    ActiveWindow.Refresh:    Application.Refresh
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
-'' QRCode二维码转矢量图
+'// QRCode二维码转矢量图
 Public Function QRCode_to_Vector()
   On Error GoTo ErrorHandler
   
@@ -286,13 +261,12 @@ End Function
 '''////  选择多物件，组合然后拆分线段，为角线爬虫准备  ////'''
 Public Function Split_Segment()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  API.BeginOpt
+
+  Dim ssr As ShapeRange, s As Shape
+  Dim nr As NodeRange, nd As Node
   
-  Dim ssr As ShapeRange
   Set ssr = ActiveSelectionRange
-  Dim s As Shape
-  Dim nr As NodeRange
-  Dim nd As Node
   
   Set s = ssr.UngroupAllEx.Combine
   Set nr = s.Curve.Nodes.all
@@ -303,27 +277,19 @@ Public Function Split_Segment()
 '    nd.BreakApart
 '  Next nd
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 
 '''////  标记画框 支持容差  ////'''
 Public Function Mark_CreateRectangle(expand As Boolean)
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   ActiveDocument.ReferencePoint = cdrBottomLeft
   Dim ssr As ShapeRange
+  Dim sh As Shape, tr As Double
   Set ssr = ActiveSelectionRange
-  Dim sh As Shape
-  Dim tr As Double
   
   tr = 0
   If GlobalUserData.Exists("Tolerance", 1) Then
@@ -338,13 +304,8 @@ Public Function Mark_CreateRectangle(expand As Boolean)
     End If
   Next sh
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 Private Function mark_shape_expand(sh As Shape, tr As Double)
@@ -388,53 +349,45 @@ End Function
 '''////  批量组合合并  ////'''
 Public Function Batch_Combine()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  
-  Dim ssr As ShapeRange
+  API.BeginOpt
+  Dim ssr As ShapeRange, sh As Shape
   Set ssr = ActiveSelectionRange
-  Dim sh As Shape
+  
   For Each sh In ssr
     sh.UngroupAllEx.Combine
   Next sh
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-  
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 '''////  一键拆开多行组合的文字字符   ////'''   ''' 本功能由群友半缘君赞助发行 '''
 Public Function Take_Apart_Character()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   ActiveDocument.ReferencePoint = cdrBottomLeft
   
   Dim ssr As ShapeRange
-  Set ssr = ActiveSelectionRange
   Dim s1 As Shape, sh As Shape, s As Shape
   Dim tr As Double
+  Set ssr = ActiveSelectionRange
   
-  ' 记忆选择范围
+  '// 记忆选择范围
   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
   Set ssr = s.BreakApartEx
 
-  ' 读取容差值
+  '// 读取容差值
   tr = 0
   If GlobalUserData.Exists("Tolerance", 1) Then
     tr = Val(GlobalUserData("Tolerance", 1))
   End If
 
-  ' 标记画框，选择标记框
+  '// 标记画框，选择标记框
   For Each sh In ssr
     mark_shape_expand sh, tr
   Next sh
@@ -443,8 +396,8 @@ Public Function Take_Apart_Character()
   ActiveDocument.ClearSelection
   ssr.AddToSelection
   
-  ' 调用 智能群组 后删除标记画框
-  智能群组和查找.智能群组
+  '// 调用 智能群组 后删除标记画框
+  SmartGroup.Smart_Group
   
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   ssr.Delete
@@ -453,19 +406,13 @@ Public Function Take_Apart_Character()
 ' sh.Shapes.All.Group
   s1.Delete
   
-  ' 通过s1矩形范围选择群组后合并组合
+  '// 通过s1矩形范围选择群组后合并组合
   For Each s In sh.Shapes
     s.UngroupAllEx.Combine
   Next s
 
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-  
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 
@@ -473,8 +420,7 @@ End Function
 Public Function Single_Line()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   
   Dim cm(2)  As Color
   Set cm(0) = CreateRGBColor(0, 255, 0) ' RGB 绿
@@ -486,14 +432,13 @@ Public Function Single_Line()
   Dim cnt As Integer
   cnt = 1
   
-
   If 1 = ActiveSelectionRange.Count Then
     Set ssr = ActiveSelectionRange(1).UngroupAllEx
   Else
     Set ssr = ActiveSelectionRange
   End If
     
-  ' 记忆选择范围
+  '// 记忆选择范围
   Dim X As Double, Y As Double, w As Double, h As Double
 
   ssr.GetBoundingBox X, Y, w, h
@@ -508,8 +453,8 @@ Public Function Single_Line()
 ' X4 不支持 ShapeRange.sort
 #End If
 
-'''  相交 Set line2 = line.Intersect(s, True, True)
-'''  判断相交  line.Curve.IntersectsWith(s.Curve)
+'//  相交   Set line2 = line.Intersect(s, True, True)
+'//  判断相交  line.Curve.IntersectsWith(s.Curve)
 
   For Each s In ssr
     If cnt > 1 Then
@@ -521,23 +466,16 @@ Public Function Single_Line()
     cnt = cnt + 1
   Next s
   
-  SrNew.group
+  SrNew.Group
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-  
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 Public Function Single_Line_Vertical()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   
   Dim cm(2)  As Color
   Set cm(0) = CreateRGBColor(0, 255, 0) ' RGB 绿
@@ -549,14 +487,13 @@ Public Function Single_Line_Vertical()
   Dim cnt As Integer
   cnt = 1
   
-
   If 1 = ActiveSelectionRange.Count Then
     Set ssr = ActiveSelectionRange(1).UngroupAllEx
   Else
     Set ssr = ActiveSelectionRange
   End If
     
-  ' 记忆选择范围
+  '// 记忆选择范围
   Dim X As Double, Y As Double, w As Double, h As Double
 
   ssr.GetBoundingBox X, Y, w, h
@@ -580,23 +517,16 @@ Public Function Single_Line_Vertical()
     cnt = cnt + 1
   Next s
   
-  SrNew.group
-  
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
+  SrNew.Group
   
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 Public Function Single_Line_LastNode()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   
   Dim cm(2)  As Color
   Set cm(0) = CreateRGBColor(0, 255, 0) ' RGB 绿
@@ -640,16 +570,10 @@ Public Function Single_Line_LastNode()
     cnt = cnt + 1
   Next s
   
-  SrNew.group
+  SrNew.Group
   
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-  
-Exit Function
 ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 
@@ -664,7 +588,7 @@ Public Function Mark_Range_Box()
 
   ssr.GetBoundingBox X, Y, w, h
   Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
-  s1.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0) ' RGB 绿
+  s1.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)  '// RGB 绿
 End Function
 
 
@@ -781,12 +705,11 @@ End Function
 
 
 '// 批量多页居中-遍历批量物件，放置物件到页面
-Public Function 批量多页居中()
+Public Function Batch_Align_Page_Center()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
+  
   Set sr = ActiveSelectionRange
   total = sr.Count
 
@@ -803,7 +726,7 @@ Public Function 批量多页居中()
 
 
   Dim sh As Shape
-  
+
   '// 遍历批量物件，放置物件到页面
   For i = 1 To sr.Count
     doc.Pages(i).Activate
@@ -820,15 +743,8 @@ Public Function 批量多页居中()
 #End If
 
   Next i
-
-  ActiveDocument.EndCommandGroup: Application.Optimization = False
-  ActiveWindow.Refresh:   Application.Refresh
-Exit Function
-
 ErrorHandler:
-  Application.Optimization = False
-  MsgBox "请先选择一些物件"
-  On Error Resume Next
+  API.EndOpt
 End Function
 
 
@@ -855,7 +771,7 @@ End Function
 
 '// 标注尺寸 批量简单标注数字
 Public Function Simple_Label_Numbers()
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   Set sr = ActiveSelectionRange
   
   For Each s In sr.Shapes
@@ -866,20 +782,19 @@ Public Function Simple_Label_Numbers()
     Set s = ActiveLayer.CreateArtisticText(0, 0, text)
     s.CenterX = X: s.BottomY = Y + 5
   Next
+  API.EndOpt
 End Function
 
 '// 修复圆角缺角到直角
-Public Sub corner_off()
+Public Function corner_off()
+  API.BeginOpt
     Dim os As ShapeRange
     Dim s As Shape, fir As Shape, ci As Shape
     Dim nd As Node, nds As Node, nde As Node
-
+    
     Set os = ActiveSelectionRange
-    ud = ActiveDocument.Unit
-    ActiveDocument.Unit = cdrMillimeter
+
 On Error GoTo errn
-    ActiveDocument.BeginCommandGroup "corners off"
-    Application.Optimization = True
     selec = False
     If os.Shapes.Count = 1 Then
         Set s = os.FirstShape
@@ -941,18 +856,13 @@ On Error GoTo errn
         End If
     End If
 errn:
-    Application.Optimization = False
-    ActiveDocument.EndCommandGroup
-    Application.Refresh
-    ActiveDocument.Unit = ud
-End Sub
+  API.EndOpt
+End Function
 
-Private Sub corner_off_make(s As Shape, nds As Node, nde As Node)
+Private Function corner_off_make(s As Shape, nds As Node, nde As Node)
     Dim l1 As Shape, l2 As Shape
     Dim os As ShapeRange
     Dim ss As Shape
-    ud = ActiveDocument.Unit
-    ActiveDocument.Unit = cdrMillimeter
 
     Set l1 = ActiveLayer.CreateLineSegment(nds.PositionX, nds.PositionY, nds.PositionX + s.SizeWidth * 3, nds.PositionY)
     l1.RotationCenterX = nds.PositionX
@@ -1007,10 +917,9 @@ Private Sub corner_off_make(s As Shape, nds As Node, nde As Node)
         l1.Delete
         l2.Delete
     End If
-    ActiveDocument.Unit = ud
-End Sub
+End Function
 
-Public Function autogroup(Optional group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
+Public Function autogroup(Optional Group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
   Dim sr As ShapeRange, sr_all As ShapeRange, os As ShapeRange
   Dim sp As SubPaths
   Dim arr()
@@ -1070,8 +979,8 @@ Public Function autogroup(Optional group As String = "group", Optional shft = 0,
         End If
       Next j
       If inar > 1 Then
-        If group = "group" Then
-          If shft < 4 Then sr_all.Add sr.group
+        If Group = "group" Then
+          If shft < 4 Then sr_all.Add sr.Group
         End If
       Else
         If sr.Shapes.Count > 0 Then sr_all.AddRange sr
@@ -1101,20 +1010,21 @@ Public Function collect_arr(arr, ci, ki)
     collect_arr = arr
 End Function
 
-' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
-' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
-' VB中用atn(), 返回值是弧度，需要 乘以 PI /180
+'// 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
+'// 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
+'// VB中用atn(), 返回值是弧度，需要 乘以 PI /180
 Private Function lineangle(x1, y1, x2, y2) As Double
-  pi = 4 * VBA.Atn(1) ' 计算圆周率
+  pi = 4 * VBA.Atn(1)    '// 计算圆周率
   If x2 = x1 Then
     lineangle = 90: Exit Function
   End If
   lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
 End Function
 
-Public Function 角度转平()
+'// 角度转平
+Public Function Angle_to_Horizon()
   On Error GoTo ErrorHandler
-'  ActiveDocument.ReferencePoint = cdrCenter
+  API.BeginOpt
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.all
 
@@ -1122,13 +1032,17 @@ Public Function 角度转平()
     x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
     x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
     a = lineangle(x1, y1, x2, y2): sr.Rotate -a
-    ' sr.LastShape.Delete   '// 删除参考线
+    sr.LastShape.Delete   '// 删除参考线
   End If
 ErrorHandler:
+  API.EndOpt
 End Function
 
-Public Function 自动旋转角度()
+'// 自动旋转角度
+Public Function Auto_Rotation_Angle()
   On Error GoTo ErrorHandler
+  API.BeginOpt
+  
 '  ActiveDocument.ReferencePoint = cdrCenter
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.all
@@ -1140,10 +1054,11 @@ Public Function 自动旋转角度()
     sr.LastShape.Delete   '// 删除参考线
   End If
 ErrorHandler:
+  API.EndOpt
 End Function
 
-
-Public Function 交换对象()
+'// 交换对象
+Public Function Exchange_Object()
   Set sr = ActiveSelectionRange
   If sr.Count = 2 Then
     X = sr.LastShape.CenterX: Y = sr.LastShape.CenterY
@@ -1152,32 +1067,33 @@ Public Function 交换对象()
   End If
 End Function
 
-Public Function 参考线镜像()
+'// 参考线镜像
+Public Function Mirror_ByGuide()
   On Error GoTo ErrorHandler
+  API.BeginOpt
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.all
 
   If nr.Count = 2 Then
-    ActiveDocument.BeginCommandGroup "Mirror": Application.Optimization = True
     byshape = False
     x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
     x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
     a = lineangle(x1, y1, x2, y2)  '// 参考线和水平的夹角 a
     sr.Remove sr.Count
     
-    ang = 90 - a  ' 镜像的旋转角度
+    ang = 90 - a    '// 镜像的旋转角度
     For Each s In sr
       With s
-        .Duplicate   ' // 复制物件保留，然后按 x1,y1 点 旋转
+        .Duplicate   '// 复制物件保留，然后按 x1,y1 点 旋转
         .RotationCenterX = x1
         .RotationCenterY = y1
         .Rotate ang
         If Not byshape Then
             lx = .LeftX
-            .Stretch -1#, 1#    ' // 通过拉伸完成镜像
+            .Stretch -1#, 1#    '// 通过拉伸完成镜像
             .LeftX = lx
             .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
-            .RotationCenterX = x1   '// 之前因为镜像，旋转中心点反了，重置回来
+            .RotationCenterX = x1     '// 之前因为镜像，旋转中心点反了，重置回来
             .RotationCenterY = y1
             .Rotate -ang
         End If
@@ -1185,21 +1101,17 @@ Public Function 参考线镜像()
         .RotationCenterY = .CenterY
       End With
     Next s
-    ActiveDocument.EndCommandGroup
+
   End If
 
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
 ErrorHandler:
-  Application.Optimization = False
+  API.EndOpt
 End Function
 
-
-Public Function 按面积排列(space_width As Double)
+'// 按面积排列计数
+Public Function Count_byArea(Space_Width As Double)
   If 0 = ActiveSelectionRange.Count Then Exit Function
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
   ActiveDocument.ReferencePoint = cdrCenter
   
   Set ssr = ActiveSelectionRange
@@ -1220,7 +1132,7 @@ Public Function 按面积排列(space_width As Double)
 
   ActiveDocument.ReferencePoint = cdrTopLeft
   For Each s In ssr
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - space_width
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - Space_Width
     cnt = cnt + 1
   Next s
 
@@ -1229,7 +1141,7 @@ Public Function 按面积排列(space_width As Double)
 '  Set f = fs.CreateTextFile("D:\size.txt", True)
 '  f.WriteLine str: f.Close
 
-  Str = 分类汇总(Str)
+  Str = Subtotals(Str)
   Debug.Print Str
 
   Dim s1 As Shape
@@ -1238,13 +1150,11 @@ Public Function 按面积排列(space_width As Double)
   Y = ssr.FirstShape.TopY
   Set s1 = ActiveLayer.CreateParagraphText(X, Y, X + 90, Y - 150, Str, Font:="华文中宋")
 
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
+  API.EndOpt
 End Function
  
 '// 实现Excel里分类汇总功能
-Private Function 分类汇总(Str As String) As String
+Private Function Subtotals(Str As String) As String
   Dim a, b, d, arr
   Str = VBA.Replace(Str, vbNewLine, " ")
   Do While InStr(Str, "  ")
@@ -1270,5 +1180,5 @@ Private Function 分类汇总(Str As String) As String
     Str = Str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
   Next
 
-  分类汇总 = Str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
+  Subtotals = Str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
 End Function