2026.05.25 Add some valuable plugin features for you to experience.

InnoSetup/CorelVBA.iss

@@ -1,8 +1,8 @@
 ; Script generated by the Inno Setup Script Wizard.
 ; SEE THE DOCUMENTATION FOR DETAILS ON CREATING INNO SETUP SCRIPT FILES!
 
-#define MyAppName "Lanya CorelVBA Test Version"
-#define MyAppVersion "2023.7.5"
+#define MyAppName "Lanya CorelVBA"
+#define MyAppVersion "2026.5.28"
 #define MyAppPublisher "lyvba.com"
 #define MyAppURL "https://lyvba.com/"
 #define MyAppExeName "GMS"
@@ -28,7 +28,7 @@ DisableProgramGroupPage=yes
 ;PrivilegesRequired=lowest
 OutputDir=C:\app\CorelVBA
 OutputBaseFilename=Lanya_CorelVBA
-SetupIconFile=C:\app\CorelVBA\GMS\LYVBA\LOGO.ico
+SetupIconFile=C:\app\CorelVBA\GMS\LYVBA\LOGO_64.ico
 Compression=lzma
 SolidCompression=yes
 WizardStyle=modern
@@ -42,7 +42,22 @@ var
   InstallDir: String;
 begin
   // 从注册表中读取安装目录
-  if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 2023', 'Destination', InstallDir) then
+    if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 2026', 'Destination', InstallDir) then
+  begin
+    Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
+  end 
+
+  else   if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 2025', 'Destination', InstallDir) then
+  begin
+    Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
+  end 
+
+  else  if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 2024', 'Destination', InstallDir) then
+  begin
+    Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
+  end 
+
+  else if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 2023', 'Destination', InstallDir) then
   begin
     Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
   end 
@@ -72,11 +87,31 @@ begin
     Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
   end 
 
+  else if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 2017', 'Destination', InstallDir) then
+  begin
+    Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
+  end 
+  
+  else if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 17', 'Destination', InstallDir) then
+  begin
+    Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
+  end 
+
   else if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 16', 'Destination', InstallDir) then
   begin
     Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
   end 
 
+  else if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 15', 'Destination', InstallDir) then
+  begin
+    Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
+  end
+
+  else if RegQueryStringValue(HKLM64, 'SOFTWARE\Corel\Setup\CorelDRAW Graphics Suite 14', 'Destination', InstallDir) then
+  begin
+    Result := ExtractFilePath(InstallDir) + 'Draw\GMS';
+  end 
+
   else
   begin
     // 如果读取失败，则使用默认安装目录
@@ -96,8 +131,13 @@ Name: "desktopicon"; Description: "{cm:CreateDesktopIcon}"; GroupDescription: "{
 
 [Files]
 Source: "C:\app\CorelVBA\GMS\LYVBA.gms"; DestDir: "{app}"; Flags: ignoreversion
-Source: "C:\app\CorelVBA\GMS\Adobe_Illustrator.gms"; DestDir: "{app}"; Flags: ignoreversion
+Source: "C:\app\CorelVBA\GMS\Lanya_LinesTool.gms"; DestDir: "{app}"; Flags: ignoreversion
+; Source: "C:\app\CorelVBA\GMS\Adobe_Illustrator.gms"; DestDir: "{app}"; Flags: ignoreversion
+Source: "C:\app\CorelVBA\GMS\ZeroBase.gms"; DestDir: "{app}"; Flags: ignoreversion
 Source: "C:\app\CorelVBA\GMS\ColorMark.cdr"; DestDir: "{app}"; Flags: ignoreversion
+Source: "C:\app\CorelVBA\GMS\README-LYVBA.md"; DestDir: "{app}"; Flags: ignoreversion
+Source: "C:\app\CorelVBA\GMS\lycpg64.cpg"; DestDir: "{app}\..\Plugins64\"; Flags: ignoreversion
+
 ; NOTE: Don't use "Flags: ignoreversion" on any shared system files
 Source: "C:\app\CorelVBA\GMS\LYVBA\*"; DestDir: "{app}\LYVBA\"; Flags: ignoreversion
 Source: "C:\app\CorelVBA\GMS\LYVBA\100\*"; DestDir: "{app}\LYVBA\100\"; Flags: ignoreversion
@@ -113,5 +153,6 @@ Name: "{autoprograms}\{#MyAppName}"; Filename: "{app}\{#MyAppExeName}"
 ;Name: "{autodesktop}\{#MyAppName}"; Filename: "{app}\{#MyAppExeName}"; Tasks: desktopicon
 
 [Run]
+
 ;Filename: "{app}\{#MyAppExeName}"; Description: "{cm:LaunchProgram,{#StringChange(MyAppName, '&', '&&')}}"; Flags: shellexec postinstall skipifsilent
 

UI/ArrangeForm.frm

@@ -36,7 +36,7 @@ Private Sub UserForm_Initialize()
   Init_Translations Me, LNG_CODE
   
   Set sr = ActiveSelectionRange
-  If sr.Count > 0 Then
+  If sr.count > 0 Then
     ls = Int(sr.SizeWidth + 0.5)
     hs = Int(sr.SizeHeight + 0.5)
     

UI/CQL_FIND_UI.frm

@@ -260,6 +260,7 @@ Private Sub CQLSameUniformColor()
   Else
     ActivePage.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
   End If
+  
   Exit Sub
 err:
   MsgBox "对象填充为空。"

UI/CardsToolsForm.frm

@@ -0,0 +1,655 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CardsToolsForm 
+   Caption         =   "CardsTools 2025"
+   ClientHeight    =   8070
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   5025
+   OleObjectBlob   =   "CardsToolsForm.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "CardsToolsForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+Private DIY_SIZE(1 To 2) As Double
+Private flag_size As Boolean
+
+
+' 这里修改绑定编号
+Private Sub Combo_Material_Change()
+    If Combo_Material.ListIndex >= 0 Then
+        If Combo_Material.ListIndex <= 1 Then
+            Text_SerialNumber.text = "2159"
+        Else
+            Text_SerialNumber.text = "2054"
+        End If
+    End If
+End Sub
+
+
+Private Sub UserForm_Initialize()
+    ' Combo_Material 材质
+    With Combo_Material
+        .AddItem "亮"  '// 文件名 替换成 过
+        .AddItem "不"  '// 前两项， 编号 2159
+        
+        .AddItem "星"  '// 后面项， 编号 2054
+        .AddItem "虹"
+        .AddItem "珠光"
+        .AddItem "碎"
+        .AddItem "厚亮"
+        .AddItem "厚过"
+        .AddItem "厚星"
+        .AddItem "厚虹"
+        .AddItem "厚碎"
+        .ListIndex = 0 ' 默认选中第一项
+        
+        ' 设置列表显示行数（等于或大于项目总数）
+        .ListRows = .ListCount  ' 显示所有项目
+    End With
+
+    ' Combo_Single_Double 单双面
+    With Combo_Single_Double
+        .AddItem "双面"
+        .AddItem "单面"
+        .ListIndex = 0 ' 默认选中第一项
+    End With
+
+    ' Combo_Quantity 数量
+    With Combo_Quantity
+        .AddItem "(1)"
+        .AddItem "(2)"
+        .AddItem "(5)"
+        .AddItem "(10)"
+        .AddItem "(20)"
+        .AddItem "(30)"
+        .AddItem "(40)"
+        .ListIndex = 2 ' 默认选中第一项
+    End With
+
+    ' Combo_StyleCount 款数
+    With Combo_StyleCount
+        .AddItem "1"
+        .AddItem "2"
+        .AddItem "3"
+        .AddItem "4"
+        .AddItem "5"
+        .AddItem "6"
+        .AddItem "7"
+        .AddItem "8"
+        .AddItem "9"
+        .AddItem "10"
+        .ListIndex = 0 ' 默认选中第一项
+        
+        ' 设置列表显示行数（等于或大于项目总数）
+        .ListRows = .ListCount  ' 显示所有项目
+    End With
+
+    ' Combo_Process 工艺
+    With Combo_Process
+        .AddItem ""
+        .AddItem "后工[切圆角(圆四角)]"
+        .AddItem "后工[特规模切(圆角85X54)]"
+        .AddItem "后工[特规模切(票根120X60)]"
+        .AddItem "后工[特规模切(票根140X70)]"
+        .AddItem "后工[压痕(居中横向压1痕)]"
+        .AddItem "后工[压痕(居中竖向压1痕)]"
+        .ListIndex = 0 ' 默认选中第一项
+        
+        ' 设置列表显示行数（等于或大于项目总数）
+        .ListRows = .ListCount  ' 显示所有项目
+    End With
+End Sub
+
+Private Sub MakeRectangle(w As Double, h As Double, Optional ByVal onekey_images As Boolean = False)
+    If Documents.count = 0 Then CreateDocument
+    API.BeginOpt
+    If onekey_images Then
+        Call Images2NewDoc
+    End If
+    Call MakeRectangleToPowerClip(w, h)
+    DIY_SIZE(1) = w: DIY_SIZE(2) = h
+    API.EndOpt
+End Sub
+
+'///***** 批量尺寸按钮代码 *****///
+Private Sub BT_54x85mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(54, 85)
+    Else
+        Call MakeRectangle(54, 85, True)
+    End If
+End Sub
+
+Private Sub BT_85x54mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(85, 54)
+    Else
+        Call MakeRectangle(85, 54, True)
+    End If
+End Sub
+
+Private Sub BT_90x54mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(90, 54)
+    Else
+        Call MakeRectangle(90, 54, True)
+    End If
+End Sub
+
+Private Sub BT_54x90mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(54, 90)
+    Else
+        Call MakeRectangle(54, 90, True)
+    End If
+End Sub
+
+Private Sub BT_90x90mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(90, 90)
+    Else
+        Call MakeRectangle(90, 90, True)
+    End If
+End Sub
+
+Private Sub BT_89x58mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(89, 58)
+    Else
+        Call MakeRectangle(89, 58, True)
+    End If
+End Sub
+
+Private Sub BT_58x89mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(58, 89)
+    Else
+        Call MakeRectangle(58, 89, True)
+    End If
+End Sub
+
+Private Sub BT_140x95mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(140, 95)
+    Else
+        Call MakeRectangle(140, 95, True)
+    End If
+End Sub
+
+Private Sub BT_95x140mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(95, 140)
+    Else
+        Call MakeRectangle(95, 140, True)
+    End If
+End Sub
+
+Private Sub BT_150x100mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(150, 100)
+    Else
+        Call MakeRectangle(150, 100, True)
+    End If
+End Sub
+
+Private Sub BT_100x150mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(100, 150)
+    Else
+        Call MakeRectangle(100, 150, True)
+    End If
+End Sub
+
+Private Sub BT_100x100mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(100, 100)
+    Else
+        Call MakeRectangle(100, 100, True)
+    End If
+End Sub
+
+Private Sub BT_54x54mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(54, 54)
+    Else
+        Call MakeRectangle(54, 54, True)
+    End If
+End Sub
+
+Private Sub BT_60x120mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(60, 120)
+    Else
+        Call MakeRectangle(60, 120, True)
+    End If
+End Sub
+
+Private Sub BT_120x60mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(120, 60)
+    Else
+        Call MakeRectangle(120, 60, True)
+    End If
+End Sub
+
+Private Sub BT_70x140mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(70, 140)
+    Else
+        Call MakeRectangle(70, 140, True)
+    End If
+End Sub
+
+Private Sub BT_140x70mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(140, 70)
+    Else
+        Call MakeRectangle(140, 70, True)
+    End If
+End Sub
+
+Private Sub BT_50x150mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(50, 150)
+    Else
+        Call MakeRectangle(50, 150, True)
+    End If
+End Sub
+
+Private Sub BT_150x50mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(150, 50)
+    Else
+        Call MakeRectangle(150, 50, True)
+    End If
+End Sub
+
+Private Sub BT_100x300mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(100, 300)
+    Else
+        Call MakeRectangle(100, 300, True)
+    End If
+End Sub
+
+Private Sub BT_300x100mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(300, 100)
+    Else
+        Call MakeRectangle(300, 100, True)
+    End If
+End Sub
+
+Private Sub BT_150x450mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(150, 450)
+    Else
+        Call MakeRectangle(150, 450, True)
+    End If
+End Sub
+
+Private Sub BT_450x150mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(450, 150)
+    Else
+        Call MakeRectangle(450, 150, True)
+    End If
+End Sub
+
+Private Sub BT_210x140mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(210, 140)
+    Else
+        Call MakeRectangle(210, 140, True)
+    End If
+End Sub
+
+Private Sub BT_140x210mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(140, 210)
+    Else
+        Call MakeRectangle(140, 210, True)
+    End If
+End Sub
+
+Private Sub BT_297x210mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(297, 210)
+    Else
+        Call MakeRectangle(297, 210, True)
+    End If
+End Sub
+
+Private Sub BT_210x297mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(210, 297)
+    Else
+        Call MakeRectangle(210, 297, True)
+    End If
+End Sub
+
+Private Sub BT_108x86mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(108, 86)
+    Else
+        Call MakeRectangle(108, 86, True)
+    End If
+End Sub
+
+Private Sub BT_86x108mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(86, 108)
+    Else
+        Call MakeRectangle(86, 108, True)
+    End If
+End Sub
+
+Private Sub BT_127x89mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(127, 89)
+    Else
+        Call MakeRectangle(127, 89, True)
+    End If
+End Sub
+
+Private Sub BT_89x127mm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(89, 127)
+    Else
+        Call MakeRectangle(89, 127, True)
+    End If
+End Sub
+
+'//////////////////////////////////
+
+
+' 生成格式化字符串的函数
+Public Function GenerateFormattedString() As String
+    Dim result As String
+    Dim separator As String
+    Dim size_xy As String
+    Dim mtl As String
+    
+    
+    separator = "-" ' 分隔符
+    
+    
+    ' 构建各部分
+    result = Trim(Text_SerialNumber.text) & separator & _
+             Replace(Trim(Text_OrderNumber.text), "-", "") & separator & "@名片"
+    
+    ' 添加材质（如果选择了）
+    If Combo_Material.ListIndex >= 0 Then
+        mtl = Combo_Material.text
+        If mtl = "亮" Then mtl = "过"
+        
+        result = result & "_" & mtl
+    End If
+    
+    ' 添加尺寸（如果有）
+    If DIY_SIZE(1) > 10 And DIY_SIZE(2) > 10 Then
+        size_xy = DIY_SIZE(1) & "X" & DIY_SIZE(2)
+        
+        If size_xy = "89X58" Then
+          size_xy = Replace(size_xy, "89X58", "85X54")
+        End If
+        
+        If size_xy = "58X89" Then
+          size_xy = Replace(size_xy, "58X89", "54X85")
+        End If
+        
+        result = result & "_" & size_xy
+    End If
+    
+    ' 添加单双面（如果选择了）
+    If Combo_Single_Double.ListIndex >= 0 Then
+        ' 去掉前后的下划线（如果不需要的话）
+        Dim singleDouble As String
+        singleDouble = Combo_Single_Double.text
+        singleDouble = Replace(singleDouble, "_", "")
+        result = result & "_" & singleDouble
+    End If
+    
+    ' 添加数量（如果选择了）
+    If Combo_Quantity.ListIndex >= 0 Then
+        ' 去掉括号和下划线
+        Dim quantity As String
+        quantity = Combo_Quantity.text
+        quantity = Replace(quantity, "_", "")
+        result = result & "_数量" & quantity
+    End If
+    
+    ' 添加款数（如果选择了）
+    If Combo_StyleCount.ListIndex >= 0 Then
+        result = result & "_" & Combo_StyleCount.text & "款"
+    End If
+    
+    ' 添加工艺（如果选择了且不是空项）
+    If Combo_Process.ListIndex >= 1 Then
+        Dim processText As String
+        processText = Combo_Process.text
+        
+        ' 去掉前导下划线
+        If Left(processText, 1) = "_" Then
+            processText = Mid(processText, 2)
+        End If
+        
+        result = result & "_" & processText
+    End If
+    
+    GenerateFormattedString = result
+End Function
+
+
+Private Sub BT_ReadFileName_Click()
+'    Dim clipText As String
+    ' 从剪贴板获取文本
+'    clipText = GetClipBoardString()
+
+    ' 检查剪贴板内容是否为空
+'    If clipText = "" Or clipText = vbNullString Then
+'       CDRX4_FileName.text = "请先准备好文件名文字复制到剪贴板"
+'    Else
+'        CDRX4_FileName.text = clipText
+'    End If
+
+   ' 验证必填项
+    If Trim(Text_SerialNumber.text) = "" Then
+        MsgBox "请填写编号", vbExclamation
+        Text_SerialNumber.SetFocus
+        Exit Sub
+    End If
+    
+    If Trim(Text_OrderNumber.text) = "" Then
+        MsgBox "请填写订单号", vbExclamation
+        Text_OrderNumber.SetFocus
+        Exit Sub
+    End If
+    
+    ' 生成格式化字符串
+    Dim formattedText As String
+    formattedText = GenerateFormattedString()
+    
+    ' 显示结果（可以根据需要复制到剪贴板或显示在文本框中）
+    ' MsgBox "生成的格式：" & vbCrLf & vbCrLf & formattedText, vbInformation
+    
+    CDRX4_FileName.text = formattedText
+
+
+End Sub
+
+
+Private Sub ClearText_OrderNumber_FileName()
+    On Error Resume Next
+    CDRX4_FileName.text = ""
+    Text_OrderNumber.text = ""
+
+'//  填加重置  工艺 和 自定义尺寸到默认
+    Combo_Material.ListIndex = 0
+    SIZE_WIDTH.text = ""
+    SIZE_HEIGHT.text = ""
+    
+End Sub
+
+Private Sub BT_SaveCDRX4_Click()
+    file = "D:\Cards\CDR保存CDR文件\" & CDRX4_FileName.text & ".cdr"
+    Save_CdrX4_File (file)
+    ClearText_OrderNumber_FileName
+End Sub
+
+Private Sub Photo_Import_Click()
+    Call Import_Images
+End Sub
+
+Private Sub PWC_Extract_Click()
+    Call PowerClip_ExtractShapes
+End Sub
+
+Private Sub SIZE_WIDTH_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+    Dim Numbers As String
+    Numbers = "1234567890"
+    If InStr(Numbers, Chr(KeyAscii)) = 0 Then
+        KeyAscii = 0
+    End If
+End Sub
+
+' 在KeyPress事件中只控制输入
+Private Sub SIZE_HEIGHT_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
+    Dim Numbers As String
+    Numbers = "1234567890"
+    If InStr(Numbers, Chr(KeyAscii)) = 0 Then
+        KeyAscii = 0
+    End If
+End Sub
+
+' 新增Change事件处理
+Private Sub SIZE_HEIGHT_Change()
+    UpdateSizePreview
+End Sub
+
+Private Sub SIZE_WIDTH_Change()
+    UpdateSizePreview
+End Sub
+
+' 统一更新函数
+Private Sub UpdateSizePreview()
+    On Error Resume Next
+
+    Dim sx As Integer, sy As Integer
+
+    ' 转换为整数
+    sx = CInt(SIZE_WIDTH.value)
+    sy = CInt(SIZE_HEIGHT.value)
+
+    ' 检查有效值
+    If sx > 29 And sy > 29 Then
+        Dim txt As String
+        txt = sx & "x" & sy & "mm"
+        BT_DIY_SIZE.Caption = txt
+        DIY_SIZE(1) = sx
+        DIY_SIZE(2) = sy
+        flag_size = True
+    Else
+        BT_DIY_SIZE.Caption = "自定义尺寸"
+        flag_size = False
+    End If
+End Sub
+
+Private Sub BT_DIY_SIZE_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If BT_DIY_SIZE.Caption = "自定义尺寸" Then
+        Exit Sub
+    End If
+
+    Dim sx As Double
+    Dim sy As Double
+    If flag_size = True Then
+        sx = DIY_SIZE(1)
+        sy = DIY_SIZE(2)
+    End If
+
+    If Button = 2 Then
+
+    ElseIf Shift = fmCtrlMask Then
+        Call MakeRectangle(sx, sy)
+    Else
+        Call MakeRectangle(sx, sy, True)
+    End If
+End Sub
+
+Private Sub BT_GET_Size_Click()
+    ActiveDocument.Unit = cdrMillimeter
+    Set sr = ActiveSelectionRange
+    sx = sr.SizeWidth: sy = sr.SizeHeight
+    sx = Int(sx + 0.5): sy = Int(sy + 0.5)
+    txt = sx & "x" & sy & "mm"
+    BT_DIY_SIZE.Caption = txt
+    DIY_SIZE(1) = sx
+    DIY_SIZE(2) = sy
+    flag_size = True
+End Sub

UI/ContainerForm.frm

@@ -0,0 +1,121 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ContainerForm 
+   Caption         =   "Everything Object as Select        github.com/hongwenjun"
+   ClientHeight    =   3015
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   5730
+   OleObjectBlob   =   "ContainerForm.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "ContainerForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private Sub UserForm_Initialize()
+  LNG_CODE = API.GetLngCode
+  Set_BoxName.Caption = i18n("Define as", LNG_CODE) & vbCrLf & i18n("Select", LNG_CODE)
+  LabelTOL.Caption = i18n("TOL:", LNG_CODE) & GlobalUserData("Tolerance", 1)
+
+  Me.Caption = i18n("Everything Object as Select", LNG_CODE) & "        github.com/hongwenjun"
+  Init_Translations Me, LNG_CODE
+  
+  txtInfo.text = i18n("Usage", LNG_CODE) & ": A->Left B->Right C->Ctrl"
+  
+End Sub
+
+Private Sub Set_BoxName_Click()
+  Container.SetBoxName
+  Create_Tolerance
+  LabelTOL.Caption = i18n("TOL:", LNG_CODE) & GlobalUserData("Tolerance", 1)
+
+End Sub
+
+Private Sub RemoveShapes_OutsideBox_Click()
+  If GlobalUserData.Exists("Tolerance", 1) Then text = GlobalUserData("Tolerance", 1)
+  Container.Remove_OutsideBox Val(text)
+End Sub
+
+Private Sub SelectOnMargin_Click()
+  Container.Select_SideBox cdrOnMarginOfShape
+End Sub
+
+Private Sub AreaSelect_Click()
+  Container.Select_SideBox cdrOnMarginOfShape + cdrInsideShape
+End Sub
+
+Private Sub SelectOutsideBox_Click()
+  Container.Select_SideBox cdrOutsideShape
+End Sub
+
+Private Sub SelectInsideBox_Click()
+  Container.Select_SideBox cdrInsideShape
+End Sub
+
+Private Sub OneKeyToPowerClip_Click()
+  Container.OneKey_ToPowerClip
+End Sub
+
+Private Sub BatchToPowerClip_Click()
+  Container.Batch_ToPowerClip
+End Sub
+
+Private Sub Select_byBlendGroup_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If GlobalUserData.Exists("Tolerance", 1) Then text = GlobalUserData("Tolerance", 1)
+
+  If Button = 2 Then
+    Container.Select_by_BlendGroup Val(text)
+    ContainerForm.Caption = i18n("If you like this feature, please visit.", LNG_CODE) & "  github.com/hongwenjun"
+    Exit Sub
+  ElseIf Shift = fmCtrlMask Then
+    Container.Select_Quick_BlendGroup Val(text)
+    LabelTOL.Caption = i18n("Right Click is Better", LNG_CODE)
+  Else
+     ' Ctrl + ЪѓБъ
+  End If
+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

UI/MakeSizePlus.frm

@@ -1,7 +1,7 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MakeSizePlus 
    Caption         =   "Batch Dimensions Plus"
-   ClientHeight    =   3690
+   ClientHeight    =   3630
    ClientLeft      =   45
    ClientTop       =   330
    ClientWidth     =   5115
@@ -13,7 +13,6 @@ 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
 
@@ -58,7 +57,7 @@ Private Sub UserForm_Initialize()
   Bleed.text = API.GetSet("Bleed")
   Line_len.text = API.GetSet("Line_len")
   Outline_Width.text = GetSetting("LYVBA", "Settings", "Outline_Width", "0.2")
-
+  Font_Size.text = GetSetting("LYVBA", "Settings", "Font_Size", "18")
 End Sub
 
 '// 关闭窗口时保存窗口位置
@@ -141,6 +140,7 @@ Private Sub Settings_Click()
    SaveSetting "LYVBA", "Settings", "Bleed", Bleed.text
    SaveSetting "LYVBA", "Settings", "Line_len", Line_len.text
    SaveSetting "LYVBA", "Settings", "Outline_Width", Outline_Width.text
+   SaveSetting "LYVBA", "Settings", "Font_Size", Font_Size.text
    Call API.Set_Space_Width  '// 设置空间间隙
   End If
 End Sub
@@ -176,7 +176,7 @@ Private Sub btn_Makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
       If s.Type = cdrLinearDimensionShape Then sr.Add s
     Next s
     sr.Delete
-    If os.Count > 0 Then
+    If os.count > 0 Then
       os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
       ActiveSelectionRange.Delete
     End If
@@ -202,7 +202,7 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
   Dim Line_len As Double
   Line_len = API.Set_Space_Width(True)  '// 读取间隔
 
-  border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + Line_len, os.TopY + 2 * 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 mirror = True Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - Line_len, os.BottomY - 2 * Line_len, _
@@ -211,9 +211,9 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
   If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then Set os = X4_Sort_ShapeRange(os, stlx)
   If dr = "lfbx" Or dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then Set os = X4_Sort_ShapeRange(os, stty).ReverseRange
 
-  If os.Count > 0 Then
-    If os.Count > 1 And Len(dr) > 2 And os.Shapes.Count > 1 Then
-      For i = 1 To os.Shapes.Count - 1
+  If os.count > 0 Then
+    If os.count > 1 And Len(dr) > 2 And os.Shapes.count > 1 Then
+      For i = 1 To os.Shapes.count - 1
         Select Case dr
           Case "upbx"
 #If VBA7 Then
@@ -222,19 +222,20 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
             Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(2), cdrDimensionStyleEngineering)
             
             If shft > 0 And i = 1 Then
-              Dimension_SetProperty sh, PresetProperty.value
+              Dimension_SetProperty sh, PresetProperty.value, mirror
               Set pts = os.FirstShape.SnapPoints.BBox(border(0))
               Set pte = os.LastShape.SnapPoints.BBox(border(1))
               Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(3), cdrDimensionStyleEngineering)
             End If
           
+          
           Case "lfbx"
             Set pts = os.Shapes(i).SnapPoints.BBox(border(4))
             Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(5))
             Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(6), 0, cdrDimensionStyleEngineering)
             
             If shft > 0 And i = 1 Then
-              Dimension_SetProperty sh, PresetProperty.value
+              Dimension_SetProperty sh, PresetProperty.value, mirror
               Set pts = os.FirstShape.SnapPoints.BBox(border(4))
               Set pte = os.LastShape.SnapPoints.BBox(border(5))
               Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(7), 0, cdrDimensionStyleEngineering)
@@ -254,7 +255,7 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
           Case "upb"
             Set pts = os.Shapes(i).SnapPoints.BBox(cdrTopRight)
             Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft)
-            Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
+            Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.topY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
             
           Case "dnb"
             Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight)
@@ -272,7 +273,7 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
             Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
         End Select
         '// 尺寸标注设置属性
-        Dimension_SetProperty sh, PresetProperty.value
+        Dimension_SetProperty sh, PresetProperty.value, mirror
         'ActiveDocument.ClearSelection
       Next i
     Else
@@ -281,7 +282,7 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
           Case "up"
             Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
             Set pte = os.LastShape.SnapPoints.BBox(cdrTopRight)
-            Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
+            Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.topY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
 
           Case "dn"
             Set pts = os.FirstShape.SnapPoints.BBox(cdrBottomLeft)
@@ -298,14 +299,14 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
             Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
             Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
         End Select
-        Dimension_SetProperty sh, PresetProperty.value
+        Dimension_SetProperty sh, PresetProperty.value, mirror
       Else
         For Each s In os.Shapes
           Select Case dr
             Case "up"
               Set pts = s.SnapPoints.BBox(cdrTopLeft)
               Set pte = s.SnapPoints.BBox(cdrTopRight)
-              Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
+              Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.topY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
             
             Case "dn"
               Set pts = s.SnapPoints.BBox(cdrBottomLeft)
@@ -322,7 +323,7 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
               Set pte = s.SnapPoints.BBox(cdrBottomRight)
               Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, s.RightX + s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
           End Select
-          Dimension_SetProperty sh, PresetProperty.value
+          Dimension_SetProperty sh, PresetProperty.value, mirror
         Next s
       End If
     End If
@@ -342,7 +343,7 @@ Sub make_sizes(Optional shft = 0)
   Dim pts As SnapPoint, pte As SnapPoint
   Dim os As ShapeRange
   Set os = ActiveSelectionRange
-  If os.Count > 0 Then
+  If os.count > 0 Then
   For Each s In os.Shapes
 #If VBA7 Then
       Set pts = s.SnapPoints.BBox(cdrTopLeft)
@@ -351,7 +352,7 @@ Sub make_sizes(Optional shft = 0)
       If shft <> 6 Then Dimension_SetProperty ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, ptle, True, _
                                               s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering), PresetProperty.value
       If shft <> 3 Then Dimension_SetProperty ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, _
-                                          s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering), PresetProperty.value
+                                          s.LeftX + s.SizeWidth / 10, s.topY + s.SizeHeight / 10, cdrDimensionStyleEngineering), PresetProperty.value
 #Else
 ' X4  There is a difference
       Set pts = s.SnapPoints(cdrTopLeft)
@@ -360,7 +361,7 @@ Sub make_sizes(Optional shft = 0)
       If shft <> 6 Then ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, ptle, True, _
                       s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering, Textsize:=18
       If shft <> 3 Then ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, _
-                      s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering, Textsize:=18
+                      s.LeftX + s.SizeWidth / 10, s.topY + s.SizeHeight / 10, cdrDimensionStyleEngineering, Textsize:=18
 #End If
   Next s
   End If
@@ -371,9 +372,7 @@ End Sub
 
 '// 使用标记线批量建立尺寸标注:   左键上标注，右键右标注
 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
-  
+  SRMInst 3, "sw"
   '// 右键
   If Button = 2 Then
     If chkOpposite.value = True Then
@@ -394,10 +393,79 @@ Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As I
         make_sizes_sep "upbx", Shift, False
     End If
   End If
+  SRMInst 3, "lw"
+End Sub
+
+'// 自动酷炫风格标注
+Private Sub CoolStyle_Click()
+  SRMInst 3, "sw"
+
+  CutLines.Dimension_MarkLines cdrAlignTop, False
+  make_sizes_sep "upbx", Shift, False
+
+  SRMInst 3, "lw"
+  CutLines.Dimension_MarkLines cdrAlignLeft, False
+  make_sizes_sep "lfbx", Shift, False
+
+  SRMInst 3, "lw"
+  CutLines.Dimension_MarkLines cdrAlignTop, True
+  make_sizes_sep "upbx", Shift, True
+
+  SRMInst 3, "lw"
+  CutLines.Dimension_MarkLines cdrAlignLeft, True
+  make_sizes_sep "lfbx", Shift, True
+  SRMInst 3, "lw"
+  
+End Sub
+
+'// 快速标注尺寸样式
+Private Sub QuickStyle_Click()
+  Dim os As ShapeRange
+  Set os = ActiveSelectionRange
+  SRMInst 3, "sw"
+  
+  CutLines.Dimension_MarkLines cdrAlignTop, True
+  make_sizes_sep "upbx", 2, True
+  SRMInst 4, "sw"
+  
+  SRMInst 3, "lw"
+  CutLines.Dimension_MarkLines cdrAlignLeft, False
+  make_sizes_sep "lfbx", Shift, False
+
+  SRMInst 4, "lw"
+  
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  sr.Sort "@shape1.left<@shape2.left"
+  If sr.count > 5 And IsAllSameSize(os) Then
+    n = sr.count
+    sr.Remove n: sr.Remove (n - 1)
+    sr.Remove 3: sr.Remove 2: sr.Remove 1
+    sr.Delete
+  End If
+  
+  SRMInst 3, "lw"
+End Sub
+
+'// 标注文字红色，分离标注
+Private Sub QuickRedText_Click()
+  SRMInst 3, "sw"
+  
+  '// 选择文本，改成红色
+  ModulePlus.Dimension_Select_or_Delete 4
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  sr.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
+  
+  '// 解绑标注线
+  SRMInst 3, "lw"
+  ModulePlus.Untie_MarkLines
+  
+  SRMInst 3, "lw"
   
-  sr.CreateSelection
 End Sub
 
+
 '// 使用手工选节点建立尺寸标注，使用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
@@ -425,9 +493,9 @@ Private Function Slanted_Makesize()
     Slanted_Sort_Make sr  '// 排序标注倾斜尺寸
     Exit Function
   End If
-  If nr.Count < 2 Then Exit Function
+  If nr.count < 2 Then Exit Function
 
-  cnt = nr.Count
+  cnt = nr.count
   While cnt > 1
     x1 = nr(cnt).PositionX
     y1 = nr(cnt).PositionY
@@ -438,7 +506,7 @@ Private Function Slanted_Makesize()
     Set pte = CreateSnapPoint(x2, y2)
     Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering)
     
-    Dimension_SetProperty sh, PresetProperty.value
+    Dimension_SetProperty sh, PresetProperty.value, mirror
     cnt = cnt - 1
   Wend
 
@@ -463,7 +531,7 @@ Private Function Slanted_Sort_Make(shs As ShapeRange)
   CutLines.RemoveDuplicates sr  '// 简单删除重复算法
   Set sr = X4_Sort_ShapeRange(sr, stlx)
 
-  For i = 1 To sr.Count - 1
+  For i = 1 To sr.count - 1
     x1 = sr(i + 1).CenterX
     y1 = sr(i + 1).CenterY
     x2 = sr(i).CenterX
@@ -486,19 +554,25 @@ ErrorHandler:
 End Function
 
 '// 尺寸标注设置属性
-Private Function Dimension_SetProperty(sh_dim As Shape, Optional ByVal Preset As Boolean = False)
+Private Function Dimension_SetProperty(sh_dim As Shape, Optional ByVal Preset As Boolean = False, Optional ByVal mirror As Boolean = False)
 #If VBA7 Then
+  plt = 0: If periphery.value And mirror Then plt = 1
+  
   If Preset And sh_dim.Type = cdrLinearDimensionShape Then
     With sh_dim.Style.GetProperty("dimension")
       .SetProperty "precision", 0 '       小数位数
       .SetProperty "showUnits", 0 '       是否显示单位 0/1
-      .SetProperty "textPlacement", 0 '   0、上方，1、下方，2、中间
+      
+      .SetProperty "textPlacement", plt  '   0、上方，1、下方，2、中间
+
     '  .SetProperty "dynamicText", 0 '    是否可以编辑尺寸0/1
     '  .SetProperty "overhang", 500000 '
     End With
   End If
   
   sh_dim.Outline.width = API.GetSet("Outline_Width")
+  sh_dim.Dimension.TextShape.text.Story.size = Font_Size.value
+  
 #Else
 ' X4  There is a difference
 #End If
@@ -506,6 +580,7 @@ End Function
 
 '// 尺寸标注左边
 Private Sub Makesize_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  SRMInst 3, "sw"
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignLeft, False
     make_sizes_sep "lfbx", Button, False
@@ -517,10 +592,12 @@ Private Sub Makesize_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
     '// Ctrl Key
     make_sizes_sep "lfb"
   End If
+  SRMInst 3, "lw"
 End Sub
 
 '// 尺寸标注右边
 Private Sub Makesize_Right_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  SRMInst 3, "sw"
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignLeft, True
     make_sizes_sep "lfbx", Button, True
@@ -532,11 +609,12 @@ Private Sub Makesize_Right_MouseUp(ByVal Button As Integer, ByVal Shift As Integ
     '// Ctrl Key
     make_sizes_sep "rib"
   End If
-
+  SRMInst 3, "lw"
 End Sub
 
 '// 尺寸标注向上
 Private Sub Makesize_Up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  SRMInst 3, "sw"
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignTop, False
     make_sizes_sep "upbx", Button, False
@@ -548,10 +626,12 @@ Private Sub Makesize_Up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer,
    '// Ctrl Key
     make_sizes_sep "upb"
   End If
+  SRMInst 3, "lw"
 End Sub
 
 '// 尺寸标注向下
 Private Sub Makesize_Down_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  SRMInst 3, "sw"
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignTop, True
     make_sizes_sep "upbx", Button, True
@@ -563,6 +643,7 @@ Private Sub Makesize_Down_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
    '// Ctrl Key
     make_sizes_sep "dnb"
   End If
+  SRMInst 3, "lw"
 End Sub
 
 Private Sub MakeRuler_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
@@ -643,7 +724,7 @@ Private Function Add_Ruler_Text(rm_lines As Boolean)
   For Each s In sr
     X = s.CenterX: Y = s.CenterY
     text = str(Int(X - sr.FirstShape.CenterX + 0.5))
-    Set t = ActiveLayer.CreateArtisticText(X, Y, text)
+    Set t = ActiveLayer.CreateArtisticText(X, Y, text, size:=Font_Size.value)
     t.CenterX = X: t.CenterY = Y
     sreg.Add t
   Next
@@ -665,7 +746,7 @@ Private Function Add_Ruler_Text_Y(rm_lines As Boolean)
   For Each s In sr
     X = s.CenterX: Y = s.CenterY
     text = str(Int(Y - sr.FirstShape.CenterY + 0.5))
-    Set t = ActiveLayer.CreateArtisticText(X, Y, text)
+    Set t = ActiveLayer.CreateArtisticText(X, Y, text, size:=Font_Size.value)
     t.Rotate 90
     t.CenterX = X: t.CenterY = Y
     sreg.Add t
@@ -730,3 +811,37 @@ End Sub
 Private Sub bt_Untie_MarkLines_Click()
   ModulePlus.Untie_MarkLines
 End Sub
+
+'// Select_Range 工具组合按钮
+Private Sub MADD_Click()
+  SRMInst 1, "add"
+End Sub
+Private Sub MSUB_Click()
+  SRMInst 1, "sub"
+End Sub
+Private Sub MRLW_Click()
+  SRMInst 1, "lw"
+End Sub
+Private Sub MZERO_Click()
+    SRMInst 1, "zero"
+    MsgBox "Selection Range is Removed!"
+End Sub
+
+'''////  CorelDRAW 与 Adobe_Illustrator 剪贴板转换  ////'''
+Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  Dim value As Integer
+  If Button = 2 Then
+    savePDFtoClip.AICopyToCdr
+    Exit Sub
+  End If
+  
+  If Button Then
+    savePDFtoClip.CdrCopyToAI
+    MsgBox "CorelDRAW 与 Adobe_Illustrator 剪贴板转换" & vbNewLine & "鼠标左键复制，鼠标右键粘贴"
+  End If
+End Sub
+
+'// 修复圆角缺角到直角
+Private Sub btn_corners_off_Click()
+  Tools.corner_off
+End Sub

UI/Make_SIZE.frm

@@ -101,18 +101,18 @@ Private Sub Dimension_width_and_height()
     Optimization = True '优化启动
     For Each s In ActiveSelection.Shapes
         If CheckBox1 Then
-            Set st1 = ActiveLayer.CreateArtisticText(s.LeftX, s.TopY + 4, Round(s.SizeWidth, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrCenterAlignment)
+            Set st1 = ActiveLayer.CreateArtisticText(s.LeftX, s.topY + 4, Round(s.SizeWidth, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrCenterAlignment)
                 st1.text.Story.CharSpacing = 0 '字符间距
                 st1.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
                 st1.Move s.SizeWidth / 2, 0
                 st1.name = "Text" ' 设置名
-            Set sox = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY + 3, s.RightX, s.TopY + 3)
+            Set sox = ActiveLayer.CreateLineSegment(s.LeftX, s.topY + 3, s.RightX, s.topY + 3)
                 sox.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
                 sox.name = "line"
-            Set sox1 = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY + 1, s.LeftX, s.TopY + 3)
+            Set sox1 = ActiveLayer.CreateLineSegment(s.LeftX, s.topY + 1, s.LeftX, s.topY + 3)
                 sox1.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
                 sox1.name = "line"
-            Set sox2 = ActiveLayer.CreateLineSegment(s.RightX, s.TopY + 1, s.RightX, s.TopY + 3)
+            Set sox2 = ActiveLayer.CreateLineSegment(s.RightX, s.topY + 1, s.RightX, s.topY + 3)
                 sox2.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
                 sox2.name = "line"
             s.CreateSelection
@@ -124,13 +124,13 @@ Private Sub Dimension_width_and_height()
             st2.Rotate 90
             st2.Move -st2.SizeWidth / 2, s.SizeHeight / 2
             st2.name = "Text" ' 设置名
-            Set soy = ActiveLayer.CreateLineSegment(s.LeftX - 3, s.BottomY, s.LeftX - 3, s.TopY)
+            Set soy = ActiveLayer.CreateLineSegment(s.LeftX - 3, s.BottomY, s.LeftX - 3, s.topY)
                 soy.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
                 soy.name = "line"
             Set soy1 = ActiveLayer.CreateLineSegment(s.LeftX - 1, s.BottomY, s.LeftX - 3, s.BottomY)
                 soy1.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
                 soy1.name = "line"
-            Set soy2 = ActiveLayer.CreateLineSegment(s.LeftX - 1, s.TopY, s.LeftX - 3, s.TopY)
+            Set soy2 = ActiveLayer.CreateLineSegment(s.LeftX - 1, s.topY, s.LeftX - 3, s.topY)
                 soy2.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
                 soy2.name = "line"
             s.CreateSelection
@@ -238,7 +238,7 @@ Private Sub Select_Font_Size()
 End Sub
 
 Private Sub Delete_callout()
-    If ActiveSelection.Shapes.Count > 0 Then
+    If ActiveSelection.Shapes.count > 0 Then
         ActiveSelection.Shapes.FindShapes(Query:="@type ='text:artistic' and @Name='Text' ").Delete
         ActiveSelection.Shapes.FindShapes(Query:="@Name='line' ").Delete
     Else

UI/PhotoForm.frm

@@ -1,7 +1,7 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} PhotoForm 
-   Caption         =   "Batch Convert Img Or Export JPEG"
-   ClientHeight    =   1755
+   Caption         =   "Batch Convert Or Export JPEG PDF"
+   ClientHeight    =   2265
    ClientLeft      =   45
    ClientTop       =   375
    ClientWidth     =   3855
@@ -16,7 +16,6 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
-
 Private Sub UserForm_Initialize()
     On Error Resume Next
     ComboBox1.AddItem "灰度"
@@ -28,6 +27,9 @@ Private Sub UserForm_Initialize()
     ComboBox2.AddItem "450", 1
     ComboBox2.AddItem "600", 2
     ComboBox2.AddItem "150", 3
+    
+    TextBox1.text = Left(ActiveDocument.fileName, InStrRev(ActiveDocument.fileName, ".") - 1)
+    
 End Sub
 
 Private Sub CovPhotos_Click()
@@ -60,15 +62,16 @@ Private Sub CovPhotos_Click()
         MsgBox "请先选中一个形状!"
         Exit Sub
     Else
-        For i = 1 To s.Count
+        For i = 1 To s.count
         Set s(i) = ActiveShape.ConvertToBitmapEx(Color, False, a, dpi, cdrNormalAntiAliasing, True, False, 95)
         Next i
     End If
     ActiveDocument.EndCommandGroup
 End Sub
 
+'// 批量导出JPEG
 Private Sub Export_JPEG_Click()
-    On Error Resume Next
+  On Error GoTo ErrorHandler
     Dim d As Document
     Set d = ActiveDocument
     Dim sh As Shape, shs As Shapes
@@ -94,14 +97,57 @@ Private Sub Export_JPEG_Click()
     opt.ResolutionY = dpi
     opt.ImageType = Color
     
-    Dim path$: path = CorelScriptTools.GetFolder
+    Dim path$: path = CorelScriptTools.GetFolder(d.FilePath)
     '// 批处理导出图片
     For Each sh In shs
         ActiveDocument.ClearSelection
         sh.CreateSelection
 
         ' 导出图片 JPEG格式
-        f = path & "\" & d.FileName & "_ID" & sh.StaticID & ".jpg"
+        f = path & "\" & TextBox1.text & "_ID" & sh.StaticID & ".jpg"
         d.Export f, cdrJPEG, cdrSelection, opt
     Next sh
+ErrorHandler:
 End Sub
+
+'// 批量导出 PDF
+Private Sub Export_PDF_Click()
+  On Error GoTo ErrorHandler
+    Dim d As Document
+    Set d = ActiveDocument
+    With d.PDFSettings
+        .PublishRange = 2 ' CdrPDFVBA.pdfSelection
+        .BitmapCompression = 1 ' CdrPDFVBA.pdfLZW
+        .JPEGQualityFactor = 2
+        .SubsetPct = 80
+        .Encoding = 1 ' CdrPDFVBA.pdfBinary
+        .ColorResolution = 300
+        .MonoResolution = 1200
+        .GrayResolution = 300
+        .Startup = 0 ' CdrPDFVBA.pdfPageOnly
+        .Overprints = True
+        .Halftones = True
+        .FountainSteps = 256
+        .pdfVersion = 6 ' CdrPDFVBA.pdfVersion15
+        .ColorMode = 3 ' CdrPDFVBA.pdfNative
+        .ColorProfile = 1 ' CdrPDFVBA.pdfSeparationProfile
+        .JP2QualityFactor = 2
+        .EncryptType = 1 ' CdrPDFVBA.pdfEncryptTypeStandard
+        .TextAsCurves = True ' 文字转曲
+    End With
+
+    '// 选择物件，按群组批量导出PDF
+    Dim path$: path = CorelScriptTools.GetFolder(d.FilePath)
+    Dim sr As ShapeRange, sh As Shape
+    Set sr = ActiveSelectionRange
+    
+    For Each sh In sr
+        ActiveDocument.ClearSelection
+        sh.CreateSelection
+        f = path & "\" & TextBox1.text & "_ID" & sh.StaticID & ".pdf"
+        d.PublishToPDF f
+    Next sh
+    
+ErrorHandler:
+End Sub
+

UI/Replace_UI.frm

@@ -12,9 +12,6 @@ Attribute VB_GlobalNameSpace = False
 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
@@ -39,6 +36,7 @@ Private Sub Close_Icon_Click()
   Unload Me    '// 关闭
 End Sub
 
+
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
   Dim hwnd As Long
@@ -138,56 +136,106 @@ Private Sub copy_shape_replace_resize()
   On Error GoTo ErrorHandler
   API.BeginOpt
 
-  ActiveDocument.ReferencePoint = cdrCenter
-  Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
-  Set shs = ActiveSelection.Shapes
-  cnt = 0
-  For Each sh In shs
-    If cnt = 0 Then
-      Set sc = ActiveDocument.ActiveLayer.Paste
-      cnt = 1
-    Else
-      sc.Duplicate 0, 0
-    End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
-    
-    sh.GetSize X, Y
-    sc.SetSize X, Y
-    sh.Delete
-    
-  Next sh
+  Set sr = ActiveSelectionRange
+  
+  If OptBt.value = True Then
+    If Select_A_Shape = True Then Set sc = ActiveSelectionRange(1)
+    OptBt.value = False
+  Else
+    Set sc = ActiveLayer.Paste
+    ActiveDocument.ClearSelection
+  End If
 
+  For Each s In sr.ReverseRange
+    vsh_SizeReplace sc, s
+  Next s
+  sc.Delete
+  
 ErrorHandler:
-'// MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
   API.EndOpt
 End Sub
 
-
 Private Sub copy_shape_replace()
   On Error GoTo ErrorHandler
   API.BeginOpt
 
-  ActiveDocument.ReferencePoint = cdrCenter
-  Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
-  Set shs = ActiveSelection.Shapes
-  cnt = 0
-  For Each sh In shs
-    If cnt = 0 Then
-      Set sc = ActiveDocument.ActiveLayer.Paste
-      cnt = 1
-    Else
-      sc.Duplicate 0, 0
-    End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
-    sh.Delete
-  Next sh
-
+  Set sr = ActiveSelectionRange
+  
+  If OptBt.value = True Then
+    If Select_A_Shape = True Then Set sc = ActiveSelectionRange(1)
+    OptBt.value = False
+  Else
+    Set sc = ActiveLayer.Paste
+    ActiveDocument.ClearSelection
+  End If
+  
+  For Each s In sr.ReverseRange
+    vsh_Replace sc, s
+  Next s
+  sc.Delete
+  
 ErrorHandler:
-'// MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
   API.EndOpt
 End Sub
 
+'// 使用虚拟形状替换: 目标 dst 替换成 源物件src
+Private Function vsh_Replace(src, dst)
+  Dim X As Double, Y As Double
+  Dim vsh As Shape
+  
+  ' 获取 目标dst 形状的中心位置
+  dst.GetPositionEx cdrCenter, X, Y
+  
+  ' 创建 源物件src 虚拟副本，并将其定位到目标dst的中心位置
+  Set vsh = src.TreeNode.GetCopy().VirtualShape
+  vsh.SetPositionEx cdrCenter, X, Y
+  
+  ' 用虚拟形状替换第二个形状
+  dst.ReplaceWith vsh
+End Function
+
+'// 使用虚拟形状替换: 目标 dst 替换成 源物件src ，并且尺寸相同
+Private Function vsh_SizeReplace(src, dst)
+  Dim X As Double, Y As Double
+  Dim vsh As Shape
+  
+  ' 创建 源物件src 虚拟副本，并将其定位到目标dst的中心位置
+  Set vsh = src.TreeNode.GetCopy().VirtualShape
+  
+  ' 尺寸相同，中心点相同
+  dst.GetSize X, Y: vsh.SetSize X, Y
+  dst.GetPositionEx cdrCenter, X, Y
+  vsh.SetPositionEx cdrCenter, X, Y
+  
+  ' 用虚拟形状替换第二个形状
+  dst.ReplaceWith vsh
+End Function
+
+' 选择一个物件对象
+Private Function Select_A_Shape() As Boolean
+    Dim X As Double, Y As Double
+    Dim Shift As Long
+    Dim b As Boolean
+    Dim sel As Shape
+
+    b = False ' 初始化布尔变量以控制循环
+
+    ' 等待用户点击以选择对象
+    While Not b
+        b = ActiveDocument.GetUserClick(X, Y, Shift, 10, False, cdrCursorWeldSingle)
+
+        If Not b Then
+            ' 获取点击位置的对象
+            Set sel = ActiveDocument.ActivePage.SelectShapesAtPoint(X, Y, False)
+
+            ' 检查是否找到对象
+            If Not sel Is Nothing Then
+                Select_A_Shape = True ' 返回成功状态
+                Exit Function
+            Else
+                MsgBox "未找到对象，请在对象上点击。"
+            End If
+        End If
+    Wend
+    Select_A_Shape = False ' 返回失败状态
+End Function

UI/Toolbar.frm

@@ -12,7 +12,6 @@ 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
 
@@ -73,7 +72,7 @@ Private Sub Change_UI_Close_Voice_Click()
   If LNG_CODE = 1033 Then
     MsgBox "Thanks For Your Support!" & vbNewLine & "Lanya Corelvba Tool Permanently Free And Open Source"
   Else
-    MsgBox "璇风粰鎴戞敮鎸�!" & vbNewLine & "鎮ㄧ殑鏀�寔锛屾垜鎵嶈兘鏈夊姩鍔涙坊鍔犳洿澶氬姛鑳�." & vbNewLine & "铇�泤CorelVBA宸ュ叿 姘镐箙鍏嶈垂寮€婧�"
+    MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA工具 永久免费开源"
   End If
 End Sub
 
@@ -104,7 +103,7 @@ Private Sub UserForm_Initialize()
   
 With Me
   .StartUpPosition = 0
-  .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400"))  ' 璁剧疆宸ュ叿鏍忎綅缃�
+  .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400"))  ' 设置工具栏位置
   .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55"))
   .Height = 30
   .width = 336
@@ -113,14 +112,14 @@ End With
   OutlineKey = True
   OptKey = True
 
-  ' 璇诲彇瑙掔嚎璁剧疆
+  ' 读取角线设置
   Bleed.text = API.GetSet("Bleed")
   Line_len.text = API.GetSet("Line_len")
   Outline_Width.text = GetSetting("LYVBA", "Settings", "Outline_Width", "0.2")
   
   UIFile = path & "GMS\LYVBA\" & HDPI.GetHDPIPercentage & "\ToolBar.jpg"
   If API.ExistsFile_UseFso(UIFile) Then
-    UI.Picture = LoadPicture(UIFile)   '鎹�I鍥�
+    UI.Picture = LoadPicture(UIFile)   '换UI图
     Set pic1 = LoadPicture(UIFile)
   End If
 
@@ -130,11 +129,11 @@ End With
     UIL_Key = True
   End If
 
-  ' 绐楀彛閫忔槑, 鏈€灏忓寲鍙�樉绀轰竴涓�浘鏍�
+  ' 窗口透明, 最小化只显示一个图标
   #If VBA7 Then
     MakeUserFormTransparent Me, RGB(26, 22, 35)
   #Else
-  ' CorelDRAW X4 / Windows7 鑷�敤鍏抽棴閫忔槑
+  ' CorelDRAW X4 / Windows7 自用关闭透明
   #End If
 End Sub
 
@@ -180,7 +179,7 @@ Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVa
   ElseIf Shift = fmCtrlMask Then
       mx = X: my = Y
   Else
-    Unload Me   ' Ctrl + 榧犳爣 鍏抽棴宸ュ叿
+    Unload Me   ' Ctrl + 鼠标 关闭工具
   End If
 End Sub
 
@@ -193,152 +192,161 @@ End Sub
 
 Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Dim c As New Color
-  ' 瀹氫箟鍥炬爣鍧愭爣pos
+  ' 定义图标坐标pos
   Dim pos_x As Variant, pos_y As Variant
   pos_y = Array(14)
   pos_x = Array(14, 41, 67, 94, 121, 148, 174, 201, 228, 254, 281, 308, 334, 361, 388, 415, 441, 468, 495)
 
-  '// 鎸変笅Ctrl閿�紝鏈€浼樺厛澶勭悊宸ュ叿鍔熻兘
+  '// 按下Ctrl键，最优先处理工具功能
   If Shift = 2 Then
     If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 瀹夊叏绾匡紝娓呴櫎杈呭姪绾�
-      Tools.guideangle ActiveSelectionRange, 3    ' 宸﹂敭 3mm 鍑鸿�
+      '// 安全线，清除辅助线
+      Tools.guideangle ActiveSelectionRange, 3    ' 左键 3mm 出血
       
     ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// Adobe AI EPS INDD PDF鍜孋orelDRAW 缂╃暐鍥惧伐鍏�
-      AdobeThumbnail_Click
+      If Github_Version = 1 Then
+        '// CardTools
+        Start_CardsTools
+      Else
+        '// Adobe AI EPS INDD PDF和CorelDRAW 缩略图工具
+        AdobeThumbnail_Click
+      End If
       
     ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 澶氱墿浠舵媶鍒嗙嚎娈�
+      '// 多物件拆分线段
       Tools.Split_Segment
       
     ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 鏅鸿兘鎷嗗瓧
-      Tools.Take_Apart_Character
+      '// 排列拼版
+      Start_Arrange
       
     ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 鏆傛椂绌�
+      '// 暂时空
       
     ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 鏆傛椂绌�
+      '// 暂时空
       
     ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 鏈ㄥご浜烘櫤鑳界兢缁勶紝寮傚舰缇ょ粍
-      autogroup("group", 1).CreateSelection
-      
+      '// 木头人智能群组，异形群组
+      '// autogroup("group", 1).CreateSelection
+
+    ElseIf Abs(X - pos_x(7)) < 14 And Abs(Y - pos_y(0)) < 14 Then
+      '// 使用 Everything Object as Select
+      Start_ContainerSelect
+    
     ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// CTRL鎵╁睍宸ュ叿鏍�
+      '// CTRL扩展工具栏
       Me.Height = 30 + 45
       
     ElseIf Abs(X - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      ' 鏂囨湰杞�洸  鍙傛暟 all=1 锛屾敮鎸佹�閫夊拰鍥炬�鍓��鍐呯殑鏂囨湰
+      ' 文本转曲  参数 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.Align_Page_Center
 
     ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     
       If Github_Version = 1 Then
-        '// 鍗曠嚎鏉¤浆瑁佸垏绾� - 鏀剧疆鍒伴〉闈㈠洓杈�
+        '// 单线条转裁切线 - 放置到页面四边
         CutLines.SelectLine_to_Cropline
       Else
-        '// 鏍囪�鑼冨洿妗�
+        '// 标记范围框
         Tools.Mark_Range_Box
       End If
 
     ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 鎵归噺璁剧疆鐗╀欢灏哄�鏁存暟
+      '// 批量设置物件尺寸整数
       Tools.Size_to_Integer
     
-    '//鍒嗗垎鍚堝悎鎶婂嚑涓�姛鑳芥寜閿�悎骞跺埌涓€璧凤紝瀹氫箟鍒板彸閿�笂
+    '//分分合合把几个功能按键合并到一起，定义到右键上
     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
-     '// 鏅鸿兘缇ょ粍
+     '// 智能群组
       SmartGroup.Smart_Group API.Create_Tolerance
       
     ElseIf Abs(X - pos_x(7)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     If Github_Version = 1 Then
       CQL_FIND_UI.Show 0
     Else
-      '// 閫夋嫨鐩稿悓宸ュ叿澧炲己鐗�
+      '// 选择相同工具增强版
       frmSelectSame.Show 0
     End If
 
     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
-     '// 鏂囨湰缁熻�淇℃伅
+     '// 文本统计信息
      Application.FrameWork.Automation.InvokeItem "bf3bd8fe-ca26-4fe0-91b0-3b5c99786fb6"
 
     ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 鍙抽敭鎺掑垪宸ュ叿
+      '// 右键排列工具
       TOP_ALIGN_BT.Visible = True
       LEFT_ALIGN_BT.Visible = True
 
     ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-      '// 鍙抽敭鎵╁睍宸ュ叿鏍忔敹缂�
+      '// 右键扩展工具栏收缩
       Me.Height = 30
       
     End If
     Exit Sub
   End If
   
-  '// 榧犳爣宸﹂敭 鍗曞嚮鎸夐挳鍔熻兘  鎸夊伐鍏锋爮涓婂浘鏍囨�甯稿姛鑳�
+  '// 鼠标左键 单击按钮功能  按工具栏上图标正常功能
   If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-   '// 瑁佸垏绾�: 鎵归噺鐗╀欢瑁佸垏绾�
+   '// 裁切线: 批量物件裁切线
     CutLines.Batch_CutLines
     
   ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-  '// 鍓�创鏉垮昂瀵稿缓绔嬬煩褰�
+  '// 剪贴板尺寸建立矩形
     ClipbRectangle.Build_Rectangle
     
   ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     If Github_Version = 1 Then
       MakeSizePlus.Show 0
     Else
-      '// 鍗曠嚎鏉¤浆瑁佸垏绾� - 鏀剧疆鍒伴〉闈㈠洓杈�
+      '// 单线条转裁切线 - 放置到页面四边
       CutLines.SelectLine_to_Cropline
     End If
   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
-    '// 鎷肩増瑁佸垏绾�
+    '// 拼版裁切线
     CutLines.Draw_Lines
     
   ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    '// 鑷�姩涓�嚎鑹查樁鏉� 褰╄壊
+    '// 自动中线色阶条 彩色
     AutoColorMark.Auto_ColorMark
     
   ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-   '// 鏅鸿兘缇ょ粍 娌″�宸�
-    SmartGroup.Smart_Group
+   '// 智能群组 没容差
+    SmartGroup.Smart_Group 1
     
   ElseIf Abs(X - pos_x(7)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     If Github_Version = 1 Then
-       '// 閫夋嫨鐩稿悓宸ュ叿澧炲己鐗�
+       '// 选择相同工具增强版
       frmSelectSame.Show 0
     Else
       CQL_FIND_UI.Show 0
@@ -348,54 +356,54 @@ 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 0
     
   ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    '// 鎵╁睍宸ュ叿鏍�
+    '// 扩展工具栏
     Me.Height = 30 + 45
     
-    Speak_Msg "宸﹀彸閿�湁涓嶅悓鍔熻兘"
+    Speak_Msg "左右键有不同功能"
     
   ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     If Me.Height > 30 Then
       Me.Height = 30
     Else
-      '// 鏈€灏忓寲
+      '// 最小化
       Me.width = 30
       Me.Height = 30
       OPEN_UI_BIG.Left = 31
       UI.Visible = False
       LOGO.Visible = True
   
-      '// 淇濆瓨宸ュ叿鏉′綅缃� Left 鍜� Top
+      '// 保存工具条位置 Left 和 Top
       SaveSetting "LYVBA", "Settings", "Left", Me.Left
       SaveSetting "LYVBA", "Settings", "Top", Me.Top
     
-      Speak_Msg "宸﹂敭缂╁皬 鍙抽敭鏀剁缉"
+      Speak_Msg "左键缩小 右键收缩"
     End If
   End If
 
 End Sub
 
 Private Sub X_EXIT_Click()
-  Unload Me    ' 鍏抽棴
+  Unload Me    ' 关闭
 End Sub
 
-'// 澶氶〉鍚堝苟宸ュ叿锛屽凡缁忓悎骞跺埌涓荤嚎宸ュ叿
-' Private Sub 璋冪敤澶氶〉鍚堝苟宸ュ叿()
+'// 多页合并工具，已经合并到主线工具
+' Private Sub 调用多页合并工具()
 '  Dim value As Integer
-'  value = GMSManager.RunMacro("鍚堝苟澶氶〉宸ュ叿", "鍚堝苟澶氶〉杩愯�.run")
+'  value = GMSManager.RunMacro("合并多页工具", "合并多页运行.run")
 ' End Sub
 
-'''///  璐�績鍟嗕汉鍜屽ソ鐜╁伐鍏风瓑  ///'''
+'''///  贪心商人和好玩工具等  ///'''
 Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     TSP.Nodes_To_TSP
   ElseIf Shift = fmCtrlMask Then
     TSP.CDR_TO_TSP
   Else
-    '// Ctrl + 榧犳爣  绌�
+    '// Ctrl + 鼠标  空
   End If
 End Sub
 
@@ -421,7 +429,7 @@ Private Sub TSP2DRAW_LINE_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
   ElseIf Shift = fmCtrlMask Then
     TSP.TSP_TO_DRAW_LINES
   Else
-    '// Ctrl + 榧犳爣  绌�
+    '// Ctrl + 鼠标  空
   End If
 End Sub
 
@@ -446,7 +454,7 @@ Private Sub BITMAP_MAKE_DOTS_Click()
   TSP.BITMAP_MAKE_DOTS
 End Sub
 
-'''///  Python鑴氭湰鍜屼簩缁寸爜绛�  ///'''
+'''///  Python脚本和二维码等  ///'''
 Private Sub Organize_Size_Click()
   Tools.Python_Organize_Size
 End Sub
@@ -471,8 +479,8 @@ Private Sub OPEN_UI_BIG_Click()
     MsgBox "Thanks For Your Support!" & vbNewLine & "Lanya Corelvba Tool Permanently Free And Open Source" _
        & vbNewLine & "GitHub: https://github.com/hongwenjun/corelvba"
   Else
-    MsgBox "璇风粰鎴戞敮鎸�!" & vbNewLine & "鎮ㄧ殑鏀�寔锛屾垜鎵嶈兘鏈夊姩鍔涙坊鍔犳洿澶氬姛鑳�." & vbNewLine & "铇�泤CorelVBA宸ュ叿 姘镐箙鍏嶈垂寮€婧�" _
-       & vbNewLine & "婧愮爜缃戝潃:" & vbNewLine & "https://github.com/hongwenjun/corelvba"
+    MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA工具 永久免费开源" _
+       & vbNewLine & "源码网址:" & vbNewLine & "https://github.com/hongwenjun/corelvba"
   End If
 End Sub
 
@@ -483,7 +491,7 @@ Private Sub Settings_Click()
    SaveSetting "LYVBA", "Settings", "Outline_Width", Outline_Width.text
   End If
 
-  ' 淇濆瓨宸ュ叿鏉′綅缃� Left 鍜� Top
+  ' 保存工具条位置 Left 和 Top
   SaveSetting "LYVBA", "Settings", "Left", Me.Left
   SaveSetting "LYVBA", "Settings", "Top", Me.Top
   
@@ -491,16 +499,16 @@ Private Sub Settings_Click()
 End Sub
 
 
-'''/////////  鍥炬爣榧犳爣宸﹀彸鐐瑰嚮鍔熻兘璋冪敤   /////////'''
+'''/////////  图标鼠标左右点击功能调用   /////////'''
 
 Private Sub Tools_Icon_Click()
-  ' 璋冪敤璇�彞
+  ' 调用语句
   i = GMSManager.RunMacro("ZeroBase", "Hello_VBA.run")
 End Sub
 
 Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-    MsgBox "宸﹂敭鎷嗗垎绾挎�锛孋trl鍚堝苟绾挎�"
+    MsgBox "左键拆分线段，Ctrl合并线段"
   ElseIf Shift = fmCtrlMask Then
     Tools.Split_Segment
   Else
@@ -508,24 +516,24 @@ Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
     Application.Refresh
   End If
   
-  Speak_Msg "鎷嗗垎绾挎�锛孋trl鍚堝苟绾挎�"
+  Speak_Msg "拆分线段，Ctrl合并线段"
 End Sub
 
-'''////  CorelDRAW 涓� Adobe_Illustrator 鍓�创鏉胯浆鎹�  ////'''
+'''////  CorelDRAW 与 Adobe_Illustrator 剪贴板转换  ////'''
 Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Dim value As Integer
   If Button = 2 Then
-    value = GMSManager.RunMacro("AIClipboard", "CopyPaste.PasteAIFormat")
+    savePDFtoClip.AICopyToCdr
     Exit Sub
   End If
   
   If Button Then
-    value = GMSManager.RunMacro("AIClipboard", "CopyPaste.CopyAIFormat")
-    MsgBox "CorelDRAW 涓� Adobe_Illustrator 鍓�创鏉胯浆鎹�" & vbNewLine & "榧犳爣宸﹂敭澶嶅埗锛岄紶鏍囧彸閿�矘璐�"
+    savePDFtoClip.CdrCopyToAI
+    MsgBox "CorelDRAW 与 Adobe_Illustrator 剪贴板转换" & vbNewLine & "鼠标左键复制，鼠标右键粘贴"
   End If
 End Sub
 
-'''////  鏍囪�鐢绘� 鏀�寔瀹瑰樊  ////'''
+'''////  标记画框 支持容差  ////'''
 Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Mark_CreateRectangle True
@@ -534,10 +542,10 @@ Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift
   Else
     Create_Tolerance
   End If
-  Speak_Msg "鏍囪�鐢绘�  鍙抽敭鏀�寔瀹瑰樊"
+  Speak_Msg "标记画框  右键支持容差"
 End Sub
 
-'''////  涓€閿�媶寮€澶氳�缁勫悎鐨勬枃瀛楀瓧绗�  ////'''
+'''////  一键拆开多行组合的文字字符  ////'''
 Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Batch_Combine
@@ -548,7 +556,7 @@ Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
   End If
 End Sub
 
-'''////  绠€鍗曚竴鍒€鍒�  ////'''
+'''////  简单一刀切  ////'''
 Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Single_Line_Vertical
@@ -559,7 +567,7 @@ Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Intege
   End If
 End Sub
 
-'''////  鍌荤摐鐏�溅鎺掑垪  ////'''
+'''////  傻瓜火车排列  ////'''
 Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Simple_Train_Arrangement 3#
@@ -570,7 +578,7 @@ Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
   End If
 End Sub
 
-'''////  鍌荤摐闃舵�鎺掑垪  ////'''
+'''////  傻瓜阶梯排列  ////'''
 Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Simple_Ladder_Arrangement 3#
@@ -582,28 +590,28 @@ Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
 End Sub
 
 
-'''////  宸﹂敭-澶氶〉鍚堝苟涓€椤靛伐鍏�   鍙抽敭-鎵归噺澶氶〉灞呬腑 ////'''
+'''////  左键-多页合并一页工具   右键-批量多页居中 ////'''
 Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     Tools.Batch_Align_Page_Center
   ElseIf Shift = fmCtrlMask Then
     UniteOne.Show 0
   Else
-    ' Ctrl + 榧犳爣  绌�
+    ' Ctrl + 鼠标  空
   End If
 End Sub
 
-'''////  Adobe AI EPS INDD PDF鍜孋orelDRAW 缂╃暐鍥惧伐鍏�  ////'''
+'''////  Adobe AI EPS INDD PDF和CorelDRAW 缩略图工具  ////'''
 Private Sub AdobeThumbnail_Click()
     Dim h As Long, r As Long
     mypath = path & "GMS\LYVBA\"
     App = mypath & "GuiAdobeThumbnail.exe"
     
-    h = FindWindow(vbNullString, "CorelVBA 闈掑勾鑺� By 铇�泤sRGB")
+    h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
     i = ShellExecute(h, "", App, "", mypath, 1)
 End Sub
 
-'''////  蹇�€熼�鑹查€夋嫨  ////'''
+'''////  快速颜色选择  ////'''
 Private Sub Quick_Color_Select_Click()
   Tools.quickColorSelect
 End Sub
@@ -614,42 +622,42 @@ Private Sub Cut_Cake_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,
   ElseIf Shift = fmCtrlMask Then
     Tools.divideHorizontally
   Else
-    ' Ctrl + 榧犳爣  绌�
+    ' Ctrl + 鼠标  空
   End If
 End Sub
 
-'// 瀹夊叏杈呭姪绾垮姛鑳斤紝涓夐敭鎺у埗锛岃�鍘岃緟鍔╃嚎鐨勪篃鍙�互鐢ㄦ潵鍒犻櫎杈呭姪绾�
+'// 安全辅助线功能，三键控制，讨厌辅助线的也可以用来删除辅助线
 Private Sub Safe_Guideangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-    Tools.guideangle ActiveSelectionRange, 0#   ' 鍙抽敭0璺濈�璐寸揣
+    Tools.guideangle ActiveSelectionRange, 0#   ' 右键0距离贴紧
   ElseIf Shift = fmCtrlMask Then
-    Tools.guideangle ActiveSelectionRange, 3    ' 宸﹂敭 3mm 鍑鸿�
+    Tools.guideangle ActiveSelectionRange, 3    ' 左键 3mm 出血
   Else
-    Tools.guideangle ActiveSelectionRange, -Set_Space_Width     ' Ctrl + 榧犳爣宸﹂敭 鑷�畾涔夐棿闅�
+    Tools.guideangle ActiveSelectionRange, -Set_Space_Width     ' Ctrl + 鼠标左键 自定义间隔
   End If
 End Sub
 
-'// 鏍囧噯灏哄�锛屽乏閿�彸閿瓹trl涓夐敭鎺у埗锛岃皟鐢ㄤ笁绉嶆牱寮�
+'// 标准尺寸，左键右键Ctrl三键控制，调用三种样式
 Private Sub btn_makesizes_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-    Make_SIZE.Show 0   '// 鍙抽敭
+    Make_SIZE.Show 0   '// 右键
   ElseIf Shift = fmCtrlMask Then
     #If VBA7 Then
       MakeSizePlus.Show 0
-    #Else  '// X4 浣跨敤
+    #Else  '// X4 使用
       Make_SIZE.Show 0
     #End If
   Else
-    Tools.Simple_Label_Numbers  '// Ctrl + 榧犳爣  鎵归噺绠€鍗曟暟瀛楁爣娉�
+    Tools.Simple_Label_Numbers  '// Ctrl + 鼠标  批量简单数字标注
   End If
 End Sub
 
-'// 鎵归噺杞�浘鐗囧拰瀵煎嚭鍥剧墖鏂囦欢
+'// 批量转图片和导出图片文件
 Private Sub Photo_Form_Click()
   PhotoForm.Show 0
 End Sub
 
-'// 淇��鍦嗚�缂鸿�鍒扮洿瑙�
+'// 修复圆角缺角到直角
 Private Sub btn_corners_off_Click()
   Tools.corner_off
 End Sub
@@ -675,7 +683,7 @@ Private Sub SwapShape_Click()
 End Sub
 
 
-'// 灏忓伐鍏峰揩閫熷惎鍔�
+'// 小工具快速启动
 Private Sub Open_Calc_Click()
   Launcher.START_Calc
 End Sub

UI/UniteOne.frm

@@ -27,7 +27,7 @@ Dim iYouyi, iXiayi As Single           '// 右移(R) 下移(B)
                                        '// txtHang, txtLie, txtYouyi, txtXiayi ,txtInfo
 Dim LogoFile As String                 '// Logo
 
-Dim s(1 To 255) As Shape   '// 定义对象用于存放每页的群组
+Dim s(1 To 1024) As Shape   '// 定义对象用于存放每页的群组
 Dim P As Page              '// 定义多页
  
 '// *********** 初始化程序 ***************
@@ -42,7 +42,7 @@ Private Sub UserForm_Initialize()
       P.Shapes.all.CreateSelection
       
       Set s = ActiveDocument.Selection
-      If s.Shapes.Count = 0 Then
+      If s.Shapes.count = 0 Then
        MsgBox i18n("The current document's first page is blank and has no objects.", LNG_CODE)
       Exit Sub
     End If

UI/frmSelectSame.frm

@@ -18,10 +18,10 @@ 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
 
-'// Attribute VB_Name = "鐩镐技閫夋嫨-榄旀敼鐗� 铇�泤"   frmSelectSame   2023.6.12
+'// Attribute VB_Name = "相似选择-魔改版 蘭雅"   frmSelectSame   2023.6.12
 
 Option Explicit
-'闇€瑕佹樉寮忓０鏄庢墍鏈夊彉閲忋€� 杩欏彲浠ラ槻姝㈡棤鎰忎腑浣跨敤缂撴參鐨勨€淰ariant鈥濈被鍨嬪彉閲忥紝杩欎簺鍙橀噺鍦ㄧ壒瀹氱被鍨嬫湭鐭ユ椂浣跨敤銆�
+'需要显式声明所有变量。 这可以防止无意中使用缓慢的“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
@@ -36,7 +36,7 @@ Private Sub UserForm_Initialize()
 End Sub
 
 Private Sub btnSelect_Click()
-    If 0 = ActiveSelectionRange.Count Then Exit Sub
+    If 0 = ActiveSelectionRange.count Then Exit Sub
     On Error GoTo ErrorHandler
     
     Dim fLeft As Double, fTop As Double
@@ -45,7 +45,7 @@ Private Sub btnSelect_Click()
     SaveSetting "SelectSame", "Preferences", "form_left", fLeft
     SaveSetting "SelectSame", "Preferences", "form_top", fTop
     
-    '// 鍖哄煙鑼冨洿閫夋嫨锛岄渶瑕佸叧闂�埛鏂颁紭鍖�
+    '// 区域范围选择，需要关闭刷新优化
     If OptBt.value = False Then
       API.BeginOpt
     Else
@@ -56,12 +56,12 @@ Private Sub btnSelect_Click()
       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"
+        MsgBox "请至少选择一个选项", vbCritical, "Select Same"
         GoTo ErrorHandler
     End If
 
 
-'// "ME"鏄�竴涓猇BA淇濈暀瀛楋紝杩斿洖瀵瑰綋鍓嶄唬鐮佹墍鍦ㄧ獥浣擄紙鎴栫被妯″潡锛夌殑寮曠敤銆� chk... 鍑芥暟杩斿洖鍚屽悕澶嶉€夋寜閽�殑褰撳墠鍊笺€�
+'// "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
@@ -100,32 +100,32 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
                     
     '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 fsn As Shape  '// 鎵╁睍鍔熻兘: 瀛椾綋瀛楀彿鏍囪�鍚嶆�娴嬫簮瀵硅薄
+    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
+    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
@@ -147,7 +147,7 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
                                             '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
@@ -156,18 +156,18 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
             Set shpsToTest = ActivePage.ActiveLayer.Shapes
         End If
         
-        If WithinDoc Then '鍦ㄥ綋鍓嶆枃妗ｆ煡鎵撅紝灏嗗綋鍓嶉〉闈㈢浉搴旂殑瀵硅薄鍔犲叆鍒板緟姣旇緝鑼冨洿
-            For i = 1 To ActiveDocument.Pages.Count
+        If WithinDoc Then '在当前文档查找，将当前页面相应的对象加入到待比较范围
+            For i = 1 To ActiveDocument.Pages.count
                 ActiveDocument.Pages(i).Activate
                 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 '鍚勯〉闈�緷娆℃煡鎵撅紝鐩稿簲鐨勫�璞″姞鍏ュ埌寰呮瘮杈冭寖鍥�
+                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
         
@@ -215,10 +215,10 @@ 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
     
-        '// 榄旀敼鍒嗘敮 瀛椾綋-瀛楀彿-鏍囪�鍚�
+        '// 魔改分支 字体-字号-标记名
         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"
@@ -226,8 +226,8 @@ Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
         End If
         
        sr.CreateSelection
-        '// 鏄剧ず鎵惧埌瀵硅薄
-        Label13.Caption = "鍏辨壘鍒� " & sr.Count & " 涓��璞�"
+        '// 显示找到对象
+        Label13.Caption = "共找到 " & sr.count & " 个对象"
     End If
     
     Set clnModelShapes = Nothing               'Release the memory allocated
@@ -236,7 +236,7 @@ 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
@@ -251,7 +251,7 @@ Private Function add_ssreg()
     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
@@ -292,23 +292,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,
@@ -369,7 +369,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
@@ -379,7 +379,7 @@ Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
                 If CountPaths Then      'Do the PATH counts match ?
                     
                     If VersionMajor > 12 Then 'GDG ##########################################
-                        If Abs(crvShape.SubPaths.Count - crvModel.SubPaths.Count) > ToleranceSubPathsCount Then GoTo NoMatch
+                        If Abs(crvShape.SubPaths.count - crvModel.SubPaths.count) > ToleranceSubPathsCount Then GoTo NoMatch
                         'MsgBox "subpaths1: " & crvShape.SubPaths.Count & "subpaths2: " & crvModel.SubPaths.Count
                     Else
                         If Abs(crvShape.SubPathCount - crvModel.SubPathCount) > ToleranceSubPathsCount Then GoTo NoMatch
@@ -393,7 +393,7 @@ Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
                 If CountNodes Then      'Do the NODE counts match ?
                 
                     If VersionMajor > 12 Then 'GDG ##########################################
-                        If Abs(crvShape.Nodes.Count - crvModel.Nodes.Count) > ToleranceNodesCount Then GoTo NoMatch
+                        If Abs(crvShape.Nodes.count - crvModel.Nodes.count) > ToleranceNodesCount Then GoTo NoMatch
                     Else
                         If Abs(crvShape.NodeCount - crvModel.NodeCount) > ToleranceNodesCount Then GoTo NoMatch
                     End If 'GDG #############################################################
@@ -403,7 +403,7 @@ Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
                 If CountSegments Then      'Do the Segments counts match ?
                 
                     If VersionMajor > 12 Then 'GDG ##########################################
-                        If Abs(crvShape.Segments.Count - crvModel.Segments.Count) > ToleranceSegmentsCount Then GoTo NoMatch
+                        If Abs(crvShape.Segments.count - crvModel.Segments.count) > ToleranceSegmentsCount Then GoTo NoMatch
                     Else
                         If Abs(crvShape.SegmentCount - crvModel.SegmentCount) > ToleranceSegmentsCount Then GoTo NoMatch
                     End If 'GDG #############################################################
@@ -549,8 +549,8 @@ Private Function GroupsMatch(Group As Shape, GroupModel As Shape, _
     Set shpsInGroup = Group.Shapes
     'On Error GoTo 0
                                         'Same number of shapes
-    lngInGroup = shpsModels.Count       'in each group ?
-    If shpsInGroup.Count <> lngInGroup Then GoTo NoMatch
+    lngInGroup = shpsModels.count       'in each group ?
+    If shpsInGroup.count <> lngInGroup Then GoTo NoMatch
         
     For i = 1 To lngInGroup             'Try to Match all sub-shapes,
         Set shpInGroup = shpsInGroup(i) 'and GroupsMatch all sub-groups.
@@ -580,7 +580,7 @@ Private Function FlatShapeList(TopLevelShapes As Shapes) As Collection
     Dim clnAllShapes As Collection  'our list of all members and
                                     'descendants of TopLevelShapes.
                                        
-    If TopLevelShapes.Count Then
+    If TopLevelShapes.count Then
         Set clnAllShapes = New Collection
         For Each shpTopLevel In TopLevelShapes
                                     'Add shape to list, keyed under

module/ALGO.bas

@@ -66,7 +66,7 @@ Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By
   Dim sp As ShapeProperties
   Dim size As Long, ret As Long
   Dim s As Shape
-  size = sr.Count
+  size = sr.count
   
   Dim sr_Array() As ShapeProperties
   Dim ret_Array() As Long
@@ -77,7 +77,7 @@ Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By
     sp.Item = sr.IndexOf(s)
     sp.StaticID = s.StaticID
     sp.lx = s.LeftX: sp.rx = s.RightX
-    sp.by = s.BottomY: sp.ty = s.TopY
+    sp.by = s.BottomY: sp.ty = s.topY
     sp.cx = s.CenterX: sp.cy = s.CenterY
     sp.sw = s.SizeWidth: sp.sh = s.SizeHeight
     sr_Array(sp.Item) = sp

module/API.bas

@@ -1,10 +1,8 @@
 Attribute VB_Name = "API"
 '// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
-
 '// Attribute VB_Name = "CorelVBA工具窗口启动"   CorelVBA Tool Window Launches  2023.6.11
 
-
 '// CorelDRAW 窗口刷新优化和关闭
 Public Function BeginOpt(Optional ByVal name As String = "Undo")
   EventsEnabled = False
@@ -26,6 +24,7 @@ Public Function EndOpt()
   ActiveDocument.EndCommandGroup
 End Function
 
+
 Public Function Speak_Msg(message As String)
   Speak_Help = Val(GetSetting("LYVBA", "Settings", "SpeakHelp", "0"))     '// 关停语音功能
   
@@ -225,7 +224,7 @@ Public Function FindAllShapes() As ShapeRange
   Dim srPowerClipped As New ShapeRange
   Dim sr As ShapeRange, srAll As New ShapeRange
   
-  If ActiveSelection.Shapes.Count > 0 Then
+  If ActiveSelection.Shapes.count > 0 Then
     Set sr = ActiveSelection.Shapes.FindShapes()
   Else
     Set sr = ActivePage.Shapes.FindShapes()
@@ -239,7 +238,7 @@ Public Function FindAllShapes() As ShapeRange
     sr.RemoveAll
     sr.AddRange srPowerClipped
     srPowerClipped.RemoveAll
-  Loop Until sr.Count = 0
+  Loop Until sr.count = 0
   
   Set FindAllShapes = srAll
 End Function

module/Arrange.bas

@@ -34,7 +34,7 @@ Public Function Arrange()
   Dim s1 As Shape
   Dim X As Double, Y As Double
   
-  If 0 = ActiveSelectionRange.Count Then
+  If 0 = ActiveSelectionRange.count Then
     X = Val(arr(0)):    Y = Val(arr(1))
     row = Int(ActiveDocument.Pages.First.SizeWidth / X)
     List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
@@ -57,7 +57,7 @@ Public Function Arrange()
       ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
 
   '// 如果当前选择物件，按当前物件拼版
-  ElseIf 0 < ActiveSelectionRange.Count Then
+  ElseIf 0 < ActiveSelectionRange.count Then
     Set s1 = ActiveSelection
     X = s1.SizeWidth:    Y = s1.SizeHeight
     row = Int(ActiveDocument.Pages.First.SizeWidth / X)

module/AutoColorMark.bas

@@ -6,7 +6,7 @@ Attribute VB_Name = "AutoColorMark"
 
 '// 请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能
 Function Auto_ColorMark()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
 
@@ -170,8 +170,11 @@ 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 '
+'//  size = size & " " & ActiveDocument.FileName & " " & Date '
   Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 7)
+  st.AlignAndDistribute 1, 1, 1, 0, False, 2
+  st.Move -3, -0.6
+  st.ConvertToCurves
 End Function
 
 #Else
@@ -240,6 +243,7 @@ Private Function put_page_size()
   Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 7)
   st.AlignToPage cdrAlignRight + cdrAlignTop
   st.Move -3, -0.6
+  st.ConvertToCurves
 End Function
 
 #End If
@@ -247,7 +251,7 @@ End Function
 
 ' 自动中线 For 黑白产品版
 Function Auto_ColorMark_K()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
   

module/CardsTools.bas

@@ -0,0 +1,215 @@
+Attribute VB_Name = "CardsTools"
+Public Function MakeRectangleToPowerClip(w As Double, h As Double)
+    Dim ssr As ShapeRange, s As Shape
+    Dim cnt As Integer
+    Dim i As Integer
+
+    Set ssr = ActiveSelectionRange
+    cnt = ssr.count
+
+    If cnt = 0 Then Exit Function
+
+    Dim jxsr As New ShapeRange
+
+    ' 为每个选择的对象创建一个矩形
+    For i = 1 To cnt
+        Set s = Rectangle(w, h)
+        jxsr.Add s
+    Next i
+
+    sr_Arrangement jxsr, 30
+    jxsr.SetOutlineProperties 0#   '// 没轮廓
+    jxsr.Move 0, jxsr.SizeHeight + 30
+
+    '// 批量调整尺寸和居中对齐
+    For i = 1 To cnt
+        SetShapeSize ssr(i), w, h
+        ssr(i).CenterX = jxsr(i).CenterX
+        ssr(i).CenterY = jxsr(i).CenterY
+        jxsr(i).name = "powerclip_ok"
+        ssr(i).AddToPowerClip jxsr(i)
+    Next i
+
+    jxsr.CreateSelection
+
+End Function
+
+'// 功能：解包当前选择的所有 PowerClip 对象
+Public Function PowerClip_ExtractShapes()
+    Dim s As Shape
+    Dim pwc As PowerClip  ' 存储 PowerClip 对象
+
+    For Each s In ActiveSelectionRange
+        Set pwc = Nothing  ' 每次循环重置变量
+        ' 错误处理：尝试获取形状的 PowerClip 属性
+        On Error Resume Next
+        Set pwc = s.PowerClip  ' 如果 s 不是 PowerClip，这里会出错
+        On Error GoTo 0        ' 恢复正常错误处理
+        ' 检查是否成功获取到 PowerClip 对象
+        If Not pwc Is Nothing Then
+            '//  s.CreateSelection     ' 选中当前 PowerClip 容器
+            pwc.ExtractShapes    ' 解包：将内容从容器中取出
+        End If
+    Next s
+End Function
+
+'// 建立矩形 Width  x Height 单位 mm
+Private Function Rectangle(width As Double, Height As Double) As Shape
+    Dim s As Shape
+    Set s = ActiveLayer.CreateRectangle(0, 0, 0 + width, 0 - Height)
+    s.Fill.ApplyNoFill
+    Set Rectangle = s
+End Function
+
+'// 简洁版本：确保一边正好等于目标尺寸，另一边不小于指定最小值
+Private Function SetShapeSize(s As Shape, w As Double, h As Double)
+    If s Is Nothing Then Exit Function
+
+    Dim originalWidth As Double
+    Dim originalHeight As Double
+    Dim ratio As Double
+
+    originalWidth = s.SizeWidth
+    originalHeight = s.SizeHeight
+    ratio = originalWidth / originalHeight
+
+    Dim newWidth As Double
+    Dim newHeight As Double
+
+    '// 尝试方案1：宽固定为85，计算高
+    newWidth = w
+    newHeight = w / ratio
+
+    '// 如果高太小（小于45），则改用方案2：高固定为54
+    If newHeight < h Then
+        newHeight = h
+        newWidth = h * ratio
+
+        '// 如果宽太小（小于85），则按比例放大直到宽等于85
+        If newWidth < w Then
+            newWidth = w
+            newHeight = w / ratio
+        End If
+    End If
+
+    '// 应用新尺寸
+    s.SetSize newWidth, newHeight
+End Function
+
+Private Function sr_Arrangement(ssr As ShapeRange, Space_Width As Double)
+    Dim s As Shape
+    Dim cnt As Integer
+    cnt = 1
+
+    ActiveDocument.ReferencePoint = cdrTopLeft
+    For Each s In ssr
+        ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
+        If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).topY
+        cnt = cnt + 1
+    Next s
+
+End Function
+
+Public Function Save_CdrX4_File(CDRX4_FileName As String)
+    Dim SaveOptions As StructSaveAsOptions
+    Set SaveOptions = CreateStructSaveAsOptions
+    With SaveOptions
+        .EmbedVBAProject = True
+        .Filter = cdrCDR
+        .IncludeCMXData = False
+        .Range = cdrAllPages
+        .EmbedICCProfile = False
+        .Version = cdrVersion14
+    End With
+
+    ActiveDocument.SaveAs CDRX4_FileName, SaveOptions
+End Function
+
+Private Function GetImageFiles(folderPath As String, fileList As Collection)
+    Dim fileName As String
+    Dim ext As String
+
+    ' 确保路径以反斜杠结尾
+    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
+
+    ' 使用Dir函数获取第一个文件
+    fileName = Dir(folderPath & "*.*")
+
+    ' 遍历所有文件
+    Do While fileName <> ""
+        ' 获取文件扩展名
+        ext = LCase(Right(fileName, Len(fileName) - InStrRev(fileName, ".")))
+
+        ' 检查是否是图片文件
+        Select Case ext
+        Case "jpg", "jpeg", "png", "gif", "bmp", "tif", "tiff"
+            fileList.Add folderPath & fileName
+        End Select
+
+        ' 获取下一个文件
+        fileName = Dir
+    Loop
+
+End Function
+
+Private Function MoveImageFile_Name(Optional ByVal sourceFileName As String, Optional ByVal destFileName As String) As Boolean
+    On Error Resume Next
+    
+    ' 如果目标文件存在，直接添加后缀
+    Dim fso As Object
+    Set fso = CreateObject("Scripting.FileSystemObject")
+    
+    If fso.FileExists(destFileName) Then
+        Dim i As Long
+        i = 1
+        Do While fso.FileExists(destFileName)
+            destFileName = Replace(destFileName, ".", "_" & i & ".")
+            i = i + 1
+        Loop
+    End If
+    
+    ' 移动文件
+    Name sourceFileName As destFileName
+    
+    MoveImageFile_Name = (err.Number = 0)
+    On Error GoTo 0
+End Function
+
+Public Function Import_Images()
+    Dim folderPath As String
+    Dim backtupPath As String
+    Dim fileList As New Collection
+    Dim sr As New ShapeRange
+
+    ' 设置文件夹路径
+    folderPath = "D:\Cards"
+    backtupPath = "D:\Cards\BACKUP"
+    Call GetImageFiles(folderPath, fileList)
+
+    ' 批量导入图片
+    Dim f As Variant
+    For Each f In fileList
+        ActiveDocument.ClearSelection
+        ActiveLayer.Import f
+        sr.Add ActiveSelection
+    Next f
+    sr.CreateSelection
+
+    ' 移动图片到备份文件夹
+    Dim sourceFileName As String
+    Dim dstFileName As String
+    For Each f In fileList
+      sourceFileName = f
+      desFileName = Replace(sourceFileName, "D:\Cards", "D:\Cards\BACKUP")
+      MoveImageFile_Name sourceFileName, desFileName
+    Next f
+    
+End Function
+
+Public Function Images2NewDoc()
+    Dim doc As Document
+    Set doc = CreateDocument()
+    doc.Unit = cdrMillimeter
+
+    Call Import_Images
+End Function

module/Container.bas

@@ -1,62 +1,56 @@
 Attribute VB_Name = "Container"
-' ① 标记容器盒子
 Public Function SetBoxName()
-  API.BeginOpt "标记容器盒子"
+  API.BeginOpt "Undo SetBoxName"
   
   Dim box As ShapeRange, s As Shape
   Set box = ActiveSelectionRange
   
-  ' 设置物件名字，以供CQL查询
   For Each s In box
-    s.Name = "Container"
+    s.name = "Container"
   Next s
   
   API.EndOpt
-  MsgBox "标记容器盒子" & vbNewLine & "名字: Container"
 End Function
 
-' 图片批量置入容器
-Public Sub Batch_ToPowerClip()
-  API.BeginOpt "批量置入容器"
+
+Public Function Batch_ToPowerClip()
+  API.BeginOpt "Batch_ToPowerClip"
   Dim s As Shape, ssr As ShapeRange, box As ShapeRange
-  Set ssr = Smart_Group(0.5) ' 智能群组容差 0.5mm
+  Set ssr = API.Smart_Group(0.5)
   
   For Each s In ssr
     Image_ToPowerClip s
   Next s
 
   API.EndOpt
-End Sub
+End Function
 
-' 图片置入容器，基本函数
 Public Function Image_ToPowerClip(arg As Shape)
+  API.BeginOpt "ToPowerClip"
   Dim box As ShapeRange
   Dim ssr As New ShapeRange, rmsr As New ShapeRange
   Set ssr = arg.UngroupEx
-  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  If box.Count = 0 Then Exit Function
+  If box.count = 0 Then Exit Function
   
-  box.SetOutlineProperties Width:=0, Color:=Nothing
+  box.SetOutlineProperties width:=0, Color:=Nothing
   ssr.AddToPowerClip box(1), 0
-  box(1).Name = "powerclip_ok"
-
+  box(1).name = "powerclip_ok"
+  API.EndOpt
 End Function
 
-' 图片OneKey置入容器
-Public Sub OneKey_ToPowerClip()
-  API.BeginOpt "图片OneKey置入容器"
+Public Function OneKey_ToPowerClip()
+  API.BeginOpt "OneKey_ToPowerClip"
   Dim s As Shape, ssr As ShapeRange, box As ShapeRange
   
-  ' 标记容器，设置透明
   Set box = ActiveSelectionRange
   For Each s In box
-    If s.Type <> cdrBitmapShape Then s.Name = "Container"
+    If s.Type <> cdrBitmapShape Then s.name = "Container"
   Next s
   
-  Set ssr = Smart_Group(0.5) ' 智能群组容差 0.5mm
+  Set ssr = API.Smart_Group(0.5)
   
   Application.Optimization = True
   For Each s In ssr
@@ -64,126 +58,144 @@ Public Sub OneKey_ToPowerClip()
   Next s
 
   API.EndOpt
-End Sub
+End Function
 
-' ② 删除容器盒子边界外面的物件    ③④
-Public Function Remove_OutsideBox()
-  Dim s As Shape
+Public Function Remove_OutsideBox(radius As Double)
+  API.BeginOpt "Undo Remove"
+  On Error GoTo ErrorHandler
+  Dim s As Shape, bc As Shape
   Dim ssr As ShapeRange, box As ShapeRange
   Dim rmsr As New ShapeRange
-  Dim x As Double, Y As Double
+  Dim X As Double, Y As Double
   
   Set ssr = ActiveSelectionRange
-  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  If box.Count = 0 Then Exit Function
+  If box.count = 0 Then GoTo ErrorHandler
+  Set bc = box(1).Duplicate(0, 0)
+  If bc.Type = cdrTextShape Then bc.ConvertToCurves
   
-  ActiveDocument.Unit = cdrMillimeter
   For Each s In ssr
-    x = s.CenterX: Y = s.CenterY
-    If box(1).IsOnShape(x, Y) = cdrOutsideShape Then rmsr.Add s
+    X = s.CenterX: Y = s.CenterY
+    If bc.IsOnShape(X, Y, radius) = cdrOutsideShape Then rmsr.Add s
   Next s
+  
+  rmsr.Add bc: rmsr.Delete: API.EndOpt
+  
+Exit Function
 
-  rmsr.Delete
-End Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
 
+End Function
 
-Public Function Remove_OnMargin()
-  Dim s As Shape
+Public Function Select_SideBox(side As cdrPositionOfPointOverShape)
+  On Error GoTo ErrorHandler
+  API.BeginOpt "Undo Select"
+  Dim s As Shape, bc As Shape
   Dim ssr As ShapeRange, box As ShapeRange
-  Dim rmsr As New ShapeRange
-  Dim x As Double, Y As Double
+  Dim SelSr As New ShapeRange
+  Dim X As Double, Y As Double, radius As Double
+  If GlobalUserData.Exists("Tolerance", 1) Then radius = Val(GlobalUserData("Tolerance", 1))
   
   Set ssr = ActiveSelectionRange
-  ' CQL查找容器盒物件
+  If ssr.count = 1 Then ssr.AddRange ActivePage.Shapes.FindShapes(Query:="!@name ='Container'")
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  If box.Count = 0 Then Exit Function
+  If box.count = 0 Then GoTo ErrorHandler
   
+  Set bc = box(1).Duplicate(0, 0)
+  bc.Fill.ApplyUniformFill CreateCMYKColor(0, 100, 0, 0)
+  If bc.Type = cdrTextShape Then bc.ConvertToCurves
+
   ActiveDocument.Unit = cdrMillimeter
   For Each s In ssr
-    x = s.CenterX: Y = s.CenterY
-    If box(1).IsOnShape(x, Y) = cdrOnMarginOfShape Then rmsr.Add s
+    X = s.CenterX: Y = s.CenterY
+    If side = (cdrInsideShape + cdrOnMarginOfShape) Then
+      If bc.IsOnShape(X, Y, s.SizeWidth / 2 * radius) = cdrInsideShape Then SelSr.Add s
+      If bc.IsOnShape(X, Y, s.SizeWidth / 2 * radius) = cdrOnMarginOfShape Then SelSr.Add s
+    Else
+      If bc.IsOnShape(X, Y, s.SizeWidth / 2 * radius) = side Then SelSr.Add s
+    End If
   Next s
+  
+  ActiveDocument.ClearSelection
+  bc.Delete: SelSr.AddToSelection: API.EndOpt
+  
+Exit Function
 
-  rmsr.Delete
+ErrorHandler:
+  Application.Optimization = False
 End Function
 
 
-Public Function Select_OutsideBox()
-  Dim s As Shape
-  Dim ssr As ShapeRange, box As ShapeRange
+Public Function Select_by_BlendGroup(radius As Double)
+  On Error GoTo ErrorHandler
+  API.BeginOpt "Undo Select"
+  Dim s As Shape, bc As Shape
+  Dim ssr As ShapeRange, box As ShapeRange, gp As ShapeRange
   Dim SelSr As New ShapeRange
-  Dim x As Double, Y As Double, radius
+  Dim X As Double, Y As Double
   
   Set ssr = ActiveSelectionRange
-  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  If box.Count = 0 Then Exit Function
-  
+  If box.count = 0 Then GoTo ErrorHandler
+  Set gp = box.Duplicate(0, 0).UngroupAllEx
+  Set gp = gp.BreakApartEx.UngroupAllEx
+
   ActiveDocument.Unit = cdrMillimeter
   For Each s In ssr
-    x = s.CenterX: Y = s.CenterY
-    radius = s.SizeWidth / 2
-    If box(1).IsOnShape(x, Y, radius) = cdrOutsideShape Then SelSr.Add s
+    X = s.CenterX: Y = s.CenterY
+    For Each bc In gp
+      If bc.IsOnShape(X, Y, s.SizeWidth / 2 * radius) = cdrOnMarginOfShape Then SelSr.Add s
+    Next bc
   Next s
   
   ActiveDocument.ClearSelection
-  SelSr.AddToSelection
+  gp.Delete: SelSr.AddToSelection: API.EndOpt
+  
+Exit Function
 
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
 End Function
 
-
-Public Function Select_OnMargin()
-  Dim s As Shape
-  Dim ssr As ShapeRange, box As ShapeRange
+Public Function Select_Quick_BlendGroup(radius As Double)
+  On Error GoTo ErrorHandler
+  API.BeginOpt "Undo Select"
+  Dim s As Shape, bc As Shape
+  Dim ssr As ShapeRange, box As ShapeRange, gp As ShapeRange
   Dim SelSr As New ShapeRange
-  Dim x As Double, Y As Double, radius
+  Dim X As Double, Y As Double
   
   Set ssr = ActiveSelectionRange
-  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  If box.Count = 0 Then Exit Function
-  
+  If box.count = 0 Then GoTo ErrorHandler
+  Set gp = box.Duplicate(0, 0).UngroupAllEx
+  Set bc = gp.BreakApartEx.UngroupAllEx.Combine
+
   ActiveDocument.Unit = cdrMillimeter
   For Each s In ssr
-    x = s.CenterX: Y = s.CenterY
-    radius = s.SizeWidth / 2
-    If box(1).IsOnShape(x, Y, radius) = cdrOnMarginOfShape Then SelSr.Add s
+    X = s.CenterX: Y = s.CenterY
+    If bc.IsOnShape(X, Y, s.SizeWidth / 2 * radius) = cdrOnMarginOfShape Then SelSr.Add s
   Next s
   
   ActiveDocument.ClearSelection
-  SelSr.AddToSelection
+  bc.Delete: SelSr.AddToSelection: API.EndOpt
+  
+Exit Function
 
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
 End Function
 
 
-' 这个子程序遍历对象，调用解散物件和居中
-Public Sub Batch_Center()
-    Dim s As Shape, ssr As ShapeRange
-    Set ssr = Smart_Group
-    For Each s In ssr
-      Ungroup_Center s
-    Next s
-End Sub
-
-
-' 以下函数，解散物件，以面积排序居中
-Private Function Ungroup_Center(os As Shape)
-    Set grp = os.UngroupEx
-    grp.Sort "@shape1.Width * @shape1.Height> @shape2.Width * @shape2.Height"
-    cx = grp(1).CenterX
-    cy = grp(1).CenterY
-    For Each s In grp
-      s.CenterX = cx
-      s.CenterY = cy
-    Next s
-End Function
-

module/CorelVBA.bas

@@ -2,12 +2,12 @@ Attribute VB_Name = "CORELVBA"
 Public Sub Start()
   Toolbar.Show 0
 '  CorelVBA.show 0
-'  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
-'  Speak_Msg "感谢您使用 蘭雅VBA工具"
+'  MsgBox "璇风粰鎴戞敮鎸�!" & vbNewLine & "鎮ㄧ殑鏀�寔锛屾垜鎵嶈兘鏈夊姩鍔涙坊鍔犳洿澶氬姛鑳�." & vbNewLine & "铇�泤CorelVBA涓��鑺傜増" & vbNewLine & "coreldrawvba鎻掍欢浜ゆ祦缇�  8531411"
+'  Speak_Msg "鎰熻阿鎮ㄤ娇鐢� 铇�泤VBA宸ュ叿"
 End Sub
 
 Sub Start_Dimension()
-  '// 尺寸标注增强版
+  '// 灏哄�鏍囨敞澧炲己鐗�
   MakeSizePlus.Show 0
 End Sub
 

module/CutLines.bas

@@ -6,7 +6,7 @@ Attribute VB_Name = "CutLines"
 
 '// 选中多个物件批量制作四角裁切线
 Public Function Batch_CutLines()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   Bleed = API.GetSet("Bleed")
   Line_len = API.GetSet("Line_len")
@@ -18,7 +18,7 @@ Public Function Batch_CutLines()
 
   For Each s1 In OrigSelection
     lx = s1.LeftX:      rx = s1.RightX
-    by = s1.BottomY:    ty = s1.TopY
+    by = s1.BottomY:    ty = s1.topY
     cx = s1.CenterX:    cy = s1.CenterY
     sw = s1.SizeWidth:  sh = s1.SizeHeight
     
@@ -52,7 +52,7 @@ End Function
 
 '// 标注尺寸标记线
 Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAlignTop, Optional ByVal mirror As Boolean = False)
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   Bleed = API.GetSet("Bleed")
   Line_len = API.GetSet("Line_len")
@@ -64,7 +64,7 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
 
   For Each s1 In OrigSelection
     lx = s1.LeftX:      rx = s1.RightX
-    by = s1.BottomY:    ty = s1.TopY
+    by = s1.BottomY:    ty = s1.topY
     
     '//  添加使用 左-上 标注尺寸标记线
     Dim s2, s6, s7, s8, s9 As Shape
@@ -85,7 +85,7 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
 '  py = ActiveDocument.Pages.First.CenterY
   '// 物件范围边界
   px = OrigSelection.LeftX
-  py = OrigSelection.TopY
+  py = OrigSelection.topY
   mpx = OrigSelection.RightX
   mpy = OrigSelection.BottomY
   
@@ -93,7 +93,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
+      s.topY = py + Line_len + Bleed
     Else
       s.LeftX = px - Line_len - Bleed
     End If
@@ -156,7 +156,7 @@ End Function
 
 '// 单线条转裁切线 - 放置到页面四边
 Public Function SelectLine_to_Cropline()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   
   '// 获得页面中心点 x,y , 设置新绘制线属性
@@ -206,7 +206,7 @@ End Function
 
 '// 拼版裁切线
 Public Function Draw_Lines()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   
   Dim OrigSelection As ShapeRange, sr As ShapeRange
@@ -217,7 +217,7 @@ Public Function Draw_Lines()
   
   ' 当前选择物件的范围边界
   set_lx = OrigSelection.LeftX:   set_rx = OrigSelection.RightX
-  set_by = OrigSelection.BottomY: set_ty = OrigSelection.TopY
+  set_by = OrigSelection.BottomY: set_ty = OrigSelection.topY
   set_cx = OrigSelection.CenterX: set_cy = OrigSelection.CenterY
   radius = 8
   Bleed = API.GetSet("Bleed")
@@ -232,7 +232,7 @@ Public Function Draw_Lines()
   For Each Target In OrigSelection
     Set s1 = Target
     lx = s1.LeftX:   rx = s1.RightX
-    by = s1.BottomY: ty = s1.TopY
+    by = s1.BottomY: ty = s1.topY
     cx = s1.CenterX: cy = s1.CenterY
     
     '// 范围边界物件判断

module/HotKeys.bas

@@ -23,10 +23,16 @@ Sub Start_CutLines()
   CutLines.Draw_Lines  '// 调用角线
 End Sub
 
-Sub AIClipboard_CopyAIFormat()
-   value = GMSManager.RunMacro("AIClipboard", "CopyPaste.CopyAIFormat")
+Sub Start_UniteOne()
+  '// 开始拼版
+   UniteOne.Show 0
+End Sub
+
+
+Sub Start_ContainerSelect()
+  ContainerForm.Show 0
 End Sub
 
-Sub AIClipboard_PasteAIFormat()
-   value = GMSManager.RunMacro("AIClipboard", "CopyPaste.PasteAIFormat")
+Sub Start_CardsTools()
+    CardsToolsForm.Show 0
 End Sub

module/ModulePlus.bas

@@ -37,7 +37,7 @@ Public Function Nodes_Reduce()
   ps = Array(1)
   doc.Unit = cdrTenthMicron
   Set os = ActivePage.Shapes
-  If os.Count > 0 Then
+  If os.count > 0 Then
     For Each s In os
     s.ConvertToCurves
       If Not s.DisplayCurve Is Nothing Then
@@ -77,7 +77,7 @@ Public Function Dimension_Select_or_Delete(Shift As Long)
       If s.Type = cdrLinearDimensionShape Then sr.Add s
     Next s
     sr.Delete
-    If os.Count > 0 Then
+    If os.count > 0 Then
       os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
       ActiveSelectionRange.Delete
     End If
@@ -98,7 +98,7 @@ Public Function Untie_MarkLines()
         dss.Add s
       End If
   Next s
-  If dss.Count > 0 Then
+  If dss.count > 0 Then
     dss.BreakApartEx
     os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
     ActiveSelectionRange.Delete
@@ -107,3 +107,21 @@ Public Function Untie_MarkLines()
 ErrorHandler:
   API.EndOpt
 End Function
+
+'// 函数：判断 ShapeRange 中的所有物件尺寸是否相同
+Function IsAllSameSize(sr As ShapeRange) As Boolean
+    Dim s As Shape
+    Dim tol As Double
+    tol = 0.01
+ 
+    For Each s In sr
+        If Abs(s.SizeWidth - sr.FirstShape.SizeWidth) > tol Or _
+           Abs(s.SizeHeight - sr.FirstShape.SizeHeight) > tol Then
+            IsAllSameSize = False
+            Exit Function
+        End If
+    Next s
+
+    IsAllSameSize = True
+End Function
+

module/SmartGroup.bas

@@ -2,63 +2,27 @@ Attribute VB_Name = "SmartGroup"
 '// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 
-'// Attribute VB_Name = "智能群组"   SmartGroup  2023.6.30
+'// Attribute VB_Name = "智能群组"   SmartGroup  2026.05.23 更换AI转的VBA 智能群群租
+
+' 定义边界框结构
+Private Type BoundingBox
+    X As Double
+    Y As Double
+    w As Double
+    h As Double
+End Type
 
 Public Function Smart_Group(Optional ByVal tr As Double = 0) As ShapeRange
-  If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
 
-  Dim OrigSelection As ShapeRange, sr As New ShapeRange
-  Dim s1 As Shape, sh As Shape, s As Shape
-  Dim X As Double, Y As Double, w As Double, h As Double
-  Dim eff1 As Effect
-  
-  Set OrigSelection = ActiveSelectionRange
-
-  '// 遍历物件画矩形
-  For Each sh In OrigSelection
-    sh.GetBoundingBox X, Y, w, h
-    If w * h > 4 Then
-      Set s = ActiveLayer.CreateRectangle2(X - tr, Y - tr, w + 2 * tr, h + 2 * tr)
-      sr.Add s
-
-    '// 轴线 创建轮廓处理
-    ElseIf w * h < 0.3 Then
-    ' Debug.Print w * h
-      Set eff1 = sh.CreateContour(cdrContourOutside, 0.5, 1, cdrDirectFountainFillBlend, CreateRGBColor(26, 22, 35), _
-              CreateRGBColor(26, 22, 35), CreateRGBColor(26, 22, 35), 0, 0, cdrContourSquareCap, cdrContourCornerMiteredOffsetBevel, 15#)
-      eff1.Separate
-    End If
-  Next sh
-
-  '// 查找轴线轮廓
-  sr.AddRange ActivePage.Shapes.FindShapes(Query:="@Outline.Color=RGB(26, 22, 35)")
-  sr.AddRange ActivePage.Shapes.FindShapes(Query:="@fill.Color=RGB(26, 22, 35)")
+  Box_AutoGroup_VBA tr   '// 2026.05.23 更换AI转的VBA 智能群群租
 
-  '// 新矩形寻找边界，散开，删除刚才画的新矩形
-  Dim brk1 As ShapeRange
-  Set s1 = sr.CustomCommand("Boundary", "CreateBoundary")
-  Set brk1 = s1.BreakApartEx
-  sr.Delete
-
-  '// 矩形边界智能群组, RetSR 返回群组 和 删除矩形s
-  Dim RetSR As New ShapeRange
-  For Each s In brk1
-    Set sr = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False).Shapes.all
-    sr.DeleteItem sr.IndexOf(s)
-    If sr.Count > 0 Then RetSR.Add sr.Group
-  Next s
-  
-  '// 智能群组返回和选择
-  Set Smart_Group = RetSR
-  RetSR.CreateSelection
-  
 ErrorHandler:
   API.EndOpt
 End Function
 
-'// 智能群组 原理版
+'// 旧智能群组 原理版
 Private Function Smart_Group_ABC()
   ActiveDocument.Unit = cdrMillimeter
   
@@ -71,10 +35,122 @@ Private Function Smart_Group_ABC()
 
   For Each s In brk1
     If s.SizeHeight > 10 Then
-      Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
+      Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.topY, s.RightX, s.BottomY, False)
       sh.Shapes.all.Group
     End If
     s.Delete
   Next
 End Function
 
+' 1. 检查两个矩形是否重叠 (AABB 碰撞检测)
+Private Function IsOverlapped(a As BoundingBox, b As BoundingBox) As Boolean
+    IsOverlapped = (a.X < b.X + b.w) And (a.X + a.w > b.X) And _
+                   (a.Y < b.Y + b.h) And (a.Y + a.h > b.Y)
+End Function
+
+' 2. 并查集：查找根节点（含路径压缩）
+Private Function FindParent(ByRef Parent() As Long, ByVal i As Long) As Long
+    If Parent(i) <> i Then
+        Parent(i) = FindParent(Parent, Parent(i))
+    End If
+    FindParent = Parent(i)
+End Function
+
+' 3. 并查集：合并集合
+Private Sub UnionSet(ByRef Parent() As Long, ByVal X As Long, ByVal Y As Long)
+    Dim rootX As Long, rootY As Long
+    rootX = FindParent(Parent, X)
+    rootY = FindParent(Parent, Y)
+    If rootX <> rootY Then Parent(rootX) = rootY
+End Sub
+
+' 核心功能：自动分组
+Public Function Box_AutoGroup_VBA(Optional ByVal exp As Double = 0)
+    Dim sr As ShapeRange
+    Set sr = ActiveSelectionRange
+    
+    ' 如果没选，尝试全选
+    If sr.count = 0 Then
+        ActivePage.Shapes.all.CreateSelection
+        Set sr = ActiveSelectionRange
+    End If
+    
+    If sr.count = 0 Then Exit Function
+
+    Dim i As Long, j As Long
+    Dim count As Long: count = sr.count
+    Dim boxes() As BoundingBox
+    Dim parentArr() As Long
+    
+    ReDim boxes(1 To count)
+    ReDim parentArr(1 To count)
+
+    ' --- 第一步：获取所有形状的边界框并初始化并查集 ---
+    Dim s As Shape
+    For i = 1 To count
+        Set s = sr.Shapes(i)
+        ' 获取边界框 (VBA 中获取左、下、宽、高)
+        s.GetBoundingBox boxes(i).X, boxes(i).Y, boxes(i).w, boxes(i).h
+        
+        ' 扩展边界框 (逻辑同 C++ expand_bounding_boxes)
+        If Abs(exp) > 0.02 Then
+            boxes(i).X = boxes(i).X - exp
+            boxes(i).Y = boxes(i).Y - exp
+            boxes(i).w = boxes(i).w + 2 * exp
+            boxes(i).h = boxes(i).h + 2 * exp
+        End If
+        
+        parentArr(i) = i ' 初始化父节点为自己
+    Next i
+
+    ' --- 第二步：运行 Union-Find 算法检测重叠 ---
+    For i = 1 To count
+        For j = i + 1 To count
+            If IsOverlapped(boxes(i), boxes(j)) Then
+                UnionSet parentArr, i, j
+            End If
+        Next j
+    Next i
+
+    ' --- 第三步：根据根节点进行物理分组 ---
+    ' 使用 Collection 模拟 C++ 的 std::map<int, std::vector<int>>
+    Dim Groups As New Collection
+    Dim rootID As Long
+    Dim groupMemberSR As ShapeRange
+    
+    ' 预处理：将同一组的形状放到一起
+    ' 我们用数组记录每个根节点对应的 ShapeRange
+    Dim GroupSRs() As ShapeRange
+    ReDim GroupSRs(1 To count)
+    
+    For i = 1 To count
+        rootID = FindParent(parentArr, i)
+        If GroupSRs(rootID) Is Nothing Then
+            Set GroupSRs(rootID) = CreateShapeRange
+        End If
+        GroupSRs(rootID).Add sr.Shapes(i)
+    Next i
+
+    
+    ActiveDocument.ClearSelection
+
+    ' 遍历并执行 Group 操作
+    Dim finalSR As New ShapeRange
+    Dim totalGroups As Long: totalGroups = 0
+    
+    For i = 1 To count
+        If Not GroupSRs(i) Is Nothing Then
+            If GroupSRs(i).count > 1 Then
+                finalSR.Add GroupSRs(i).Group
+                totalGroups = totalGroups + 1
+            Else
+                finalSR.Add GroupSRs(i)(1)
+                totalGroups = totalGroups + 1
+            End If
+        End If
+    Next i
+
+    finalSR.CreateSelection
+    
+End Function
+

module/StoreSelect.bas

@@ -1,14 +1,14 @@
 Attribute VB_Name = "StoreSelect"
-Private sr_mem(3) As New ShapeRange
+Public sr_mem(5) 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
+  StoreCount = "Store Count: A->" & sr_mem(1).count & "  B->" & sr_mem(2).count & "  C->" & sr_mem(3).count
 
 ErrorHandler:
   API.EndOpt
@@ -22,17 +22,23 @@ Private Function Case_Select_Range(id As Integer, INST As String)
     Case "sub"
       sr_mem(id).RemoveRange ActiveSelectionRange
     Case "lw"
-     '// ActiveDocument.ClearSelection
-      sr_mem(id).AddToSelection
+      '// ActiveDocument.ClearSelection
+      '// sr_mem(id).AddToSelection
+      sr_mem(id).CreateSelection
     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 If
+    Case "sw"
+      sr_mem(id).RemoveAll
+      sr_mem(id).AddRange ActiveSelectionRange
   End Select
 
 ErrorHandler:
-  API.EndOpt
+End Function
+
+Public Function SRMInst(id As Integer, INST As String)
+  Case_Select_Range id, INST
 End Function

module/TSP.bas

@@ -10,7 +10,7 @@ Public Function CDR_TO_TSP()
   Set shs = ActiveSelection.Shapes
   
   Dim TSP As String
-  TSP = shs.Count & " " & 0 & vbNewLine
+  TSP = shs.count & " " & 0 & vbNewLine
   For Each sh In shs
     X = sh.CenterX
     Y = sh.CenterY
@@ -44,7 +44,7 @@ Public Function Nodes_To_TSP()
   Set s = ssr.UngroupAllEx.Combine
   Set nr = s.Curve.Nodes.all
   
-  TSP = nr.Count & " " & 0 & vbNewLine
+  TSP = nr.count & " " & 0 & vbNewLine
   For Each n In nr
       X = Round(n.PositionX, 3) & " "
       Y = Round(n.PositionY, 3) & vbNewLine

module/ThisMacroStorage.cls

@@ -49,4 +49,3 @@ Private Function refresh_Icon()
     .Controls.Item(4).SetIcon2 ("guid://1a0b1202-d0ef-4fe7-8a95-ac7617b30703")
   End With
 End Function
-

module/Tools.bas

@@ -4,6 +4,7 @@ Attribute VB_Name = "Tools"
 
 '// 简易火车排列
 Public Function Simple_Train_Arrangement(Space_Width As Double)
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   Dim ssr As ShapeRange, s As Shape
   Dim cnt As Integer
@@ -23,7 +24,7 @@ Public Function Simple_Train_Arrangement(Space_Width As Double)
     '// 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
     '// 改成顶对齐 2022-08-10
     ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).TopY
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).topY
     cnt = cnt + 1
   Next s
 
@@ -32,6 +33,7 @@ End Function
 
 '// 简易阶梯排列
 Public Function Simple_Ladder_Arrangement(Space_Width As Double)
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   Dim ssr As ShapeRange, s As Shape
   Dim cnt As Integer
@@ -87,6 +89,7 @@ End Function
 
 '// 旋转物件角度
 Public Function Rotate_Shapes(n As Double)
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   
   Dim sh As Shape, shs As Shapes
@@ -112,6 +115,7 @@ End Function
 
 '// 批量设置物件尺寸
 Public Function Set_Shapes_size(ByRef sx As Double, ByRef sy As Double)
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   ActiveDocument.ReferencePoint = cdrCenter
   
@@ -128,7 +132,7 @@ End Function
 
 '// 批量设置物件尺寸整数
 Public Function Size_to_Integer()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   '// 修改变形尺寸基准
   ActiveDocument.ReferencePoint = cdrCenter
@@ -150,7 +154,7 @@ End Function
 
 '// 设置物件页面居中
 Public Function Align_Page_Center()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   '// 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
   API.BeginOpt
   
@@ -407,7 +411,7 @@ Public Function Take_Apart_Character()
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   ssr.Delete
   
-  Set sh = ActivePage.SelectShapesFromRectangle(s1.LeftX, s1.TopY, s1.RightX, s1.BottomY, False)
+  Set sh = ActivePage.SelectShapesFromRectangle(s1.LeftX, s1.topY, s1.RightX, s1.BottomY, False)
 ' sh.Shapes.All.Group
   s1.Delete
   
@@ -423,7 +427,7 @@ End Function
 
 '''//// 简单一刀切 识别群组 ////''' ''' 本功能由群友宏瑞广告赞助发行 '''
 Public Function Single_Line()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
   
@@ -437,7 +441,7 @@ Public Function Single_Line()
   Dim cnt As Integer
   cnt = 1
   
-  If 1 = ActiveSelectionRange.Count Then
+  If 1 = ActiveSelectionRange.count Then
     Set ssr = ActiveSelectionRange(1).UngroupAllEx
   Else
     Set ssr = ActiveSelectionRange
@@ -464,7 +468,7 @@ Public Function Single_Line()
   For Each s In ssr
     If cnt > 1 Then
       s.ConvertToCurves
-      Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY, s.LeftX, s.TopY - s.SizeHeight)
+      Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.topY, s.LeftX, s.topY - s.SizeHeight)
       line.Outline.SetProperties Color:=cm(1)
       SrNew.Add line
     End If
@@ -478,7 +482,7 @@ ErrorHandler:
 End Function
 
 Public Function Single_Line_Vertical()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
   
@@ -492,7 +496,7 @@ Public Function Single_Line_Vertical()
   Dim cnt As Integer
   cnt = 1
   
-  If 1 = ActiveSelectionRange.Count Then
+  If 1 = ActiveSelectionRange.count Then
     Set ssr = ActiveSelectionRange(1).UngroupAllEx
   Else
     Set ssr = ActiveSelectionRange
@@ -515,7 +519,7 @@ Public Function Single_Line_Vertical()
   For Each s In ssr
     If cnt > 1 Then
       s.ConvertToCurves
-      Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY, s.RightX, s.TopY)
+      Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.topY, s.RightX, s.topY)
       line.Outline.SetProperties Color:=cm(1)
       SrNew.Add line
     End If
@@ -529,7 +533,7 @@ ErrorHandler:
 End Function
 
 Public Function Single_Line_LastNode()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
   
@@ -544,7 +548,7 @@ Public Function Single_Line_LastNode()
   cnt = 1
   
 
-  If 1 = ActiveSelectionRange.Count Then
+  If 1 = ActiveSelectionRange.count Then
     Set ssr = ActiveSelectionRange(1).UngroupAllEx
   Else
     Set ssr = ActiveSelectionRange
@@ -584,7 +588,7 @@ End Function
 
 '''//// 选择范围画框 ////'''
 Public Function Mark_Range_Box()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   ActiveDocument.Unit = cdrMillimeter
   Dim s1 As Shape, ssr As ShapeRange
   
@@ -635,7 +639,7 @@ End Function
 
 '''//// 切割图形-垂直分割-水平分割 ////'''
 Function divideVertically()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   
@@ -652,7 +656,7 @@ ErrorHandler:
 End Function
 
 Function divideHorizontally()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   
@@ -711,13 +715,13 @@ End Function
 
 '// 批量多页居中-遍历批量物件，放置物件到页面
 Public Function Batch_Align_Page_Center()
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   On Error GoTo ErrorHandler
   API.BeginOpt
   
   Dim sr As ShapeRange
   Set sr = ActiveSelectionRange
-  total = sr.Count
+  total = sr.count
 
   '// 建立多页面
   Set doc = ActiveDocument
@@ -727,7 +731,7 @@ Public Function Batch_Align_Page_Center()
 
   Dim sh As Shape
   '// 遍历批量物件，放置物件到页面  InsertPagesEx   ActivePage
-  For i = 1 To sr.Count
+  For i = 1 To sr.count
     doc.Pages(i).Activate
     Set sh = sr.Shapes(i)
     ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
@@ -754,16 +758,16 @@ End Function
 Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
   Dim sr As ShapeRange
   Set sr = ActiveDocument.MasterPage.GuidesLayer.FindShapes(Type:=cdrGuidelineShape)
-  If sr.Count <> 0 Then
+  If sr.count <> 0 Then
     sr.Delete
     Exit Function
   End If
   
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   ActiveDocument.Unit = cdrMillimeter
 
   With actnumber
-    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .TopY - cardblood, 0#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .topY - cardblood, 0#)
     Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .BottomY + cardblood, 0#)
     Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.LeftX + cardblood, 0, 90#)
     Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.RightX - cardblood, 0, 90#)
@@ -777,7 +781,7 @@ Public Function Simple_Label_Numbers()
   Set sr = ActiveSelectionRange
   
   For Each s In sr.Shapes
-    X = s.CenterX: Y = s.TopY
+    X = s.CenterX: Y = s.topY
     sw = s.SizeWidth: sh = s.SizeHeight
           
     text = Int(sw + 0.5) & "x" & Int(sh + 0.5) & "mm"
@@ -798,7 +802,7 @@ Public Function corner_off()
 
 On Error GoTo errn
     selec = False
-    If os.Shapes.Count = 1 Then
+    If os.Shapes.count = 1 Then
         Set s = os.FirstShape
         If Not s.Curve Is Nothing Then
             For Each nd In s.Curve.Nodes
@@ -810,14 +814,14 @@ On Error GoTo errn
         End If
     End If
     
-    If os.Shapes.Count > 1 Or Not selec Then
+    If os.Shapes.count > 1 Or Not selec Then
         os.ConvertToCurves
         For Each s In os.Shapes
             Set nds = Nothing
             Set nde = Nothing
             For k = 1 To 3
-            For i = 1 To s.Curve.Nodes.Count
-                If i <= s.Curve.Nodes.Count Then
+            For i = 1 To s.Curve.Nodes.count
+                If i <= s.Curve.Nodes.count Then
                     Set nd = s.Curve.Nodes(i)
                     If Not nd.NextSegment Is Nothing And Not nd.PrevSegment Is Nothing Then
                         If Abs(nd.PrevSegment.Length - nd.NextSegment.Length) < (nd.PrevSegment.Length + nd.NextSegment.Length) / 30 And nd.PrevSegment.Type = cdrCurveSegment And nd.NextSegment.Type = cdrCurveSegment Then
@@ -836,14 +840,14 @@ On Error GoTo errn
             
              
         Next s
-    ElseIf os.Shapes.Count = 1 And selec Then
+    ElseIf os.Shapes.count = 1 And selec Then
         Set nds = Nothing
         Set nde = Nothing
         For Each nd In s.Curve.Nodes
             If Not nd.Selected And Not nd.Next.Selected Then Exit For
         Next nd
         If Not nd Is s.Curve.Nodes.Last Then
-            For i = 1 To s.Curve.Nodes.Count
+            For i = 1 To s.Curve.Nodes.count
                 Set nd = nd.Next
                 If Not nde Is Nothing And Not nds Is Nothing And Not nd.Selected Then Exit For
                 If Not nds Is Nothing And nd.Selected Then Set nde = nd
@@ -875,7 +879,7 @@ Private Function corner_off_make(s As Shape, nds As Node, nde As Node)
     l2.RotationAngle = nde.NextSegment.StartingControlPointAngle + 180
     
     Set lcross = l2.Curve.Segments.First.GetIntersections(l1.Curve.Segments.First)
-    If lcross.Count > 0 Then
+    If lcross.count > 0 Then
         cx = lcross(1).PositionX
         cy = lcross(1).PositionY
         sx = nds.PositionX
@@ -890,7 +894,7 @@ Private Function corner_off_make(s As Shape, nds As Node, nde As Node)
         
         s.Curve.Nodes.Range(Array(nds.AbsoluteIndex, nde.AbsoluteIndex)).BreakApart
         Set os = s.BreakApartEx
-        oscnt = os.Shapes.Count
+        oscnt = os.Shapes.count
         For Each ss In os.Shapes
             If ss.Curve.Nodes.First.PositionX = ex And ss.Curve.Nodes.First.PositionY = ey Then Set s2 = ss
             If ss.Curve.Nodes.Last.PositionX = sx And ss.Curve.Nodes.Last.PositionY = sy Then Set s1 = ss
@@ -921,97 +925,6 @@ Private Function corner_off_make(s As Shape, nds As Node, nde As Node)
     End If
 End Function
 
-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()
-  Dim s As Shape
-  If sss Is Nothing Then Set os = ActiveSelectionRange Else Set os = sss.all
-  On Error GoTo errn
-  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  
-  If ActiveSelection.Shapes.Count > 0 Then
-    gcnt = os.Shapes.Count
-    ReDim arr(1 To gcnt, 1 To gcnt)
-    Set sr_all = ActiveSelectionRange
-    sr_all.RemoveAll
-    ReDim arr(1 To gcnt, 1 To gcnt)
-    ActiveDocument.Unit = cdrTenthMicron
-    sgap = 10
-    If shft = 2 Or shft = 3 Or shft = 6 Or shft = 7 Then
-      os.RemoveAll
-      For Each s In ActiveSelectionRange.Shapes
-          os.Add ActivePage.SelectShapesFromRectangle(s.LeftX - sgap, s.BottomY - sgap, s.RightX + sgap, s.TopY + sgap, True)
-      Next s
-    End If
-    
-    For i = 1 To os.Shapes.Count
-      Set s1 = os.Shapes(i)
-      arr(i, i) = i
-      For j = 1 To os.Shapes.Count
-        Set s2 = os.Shapes(j)
-        If s2.LeftX < s1.RightX + sgap And s2.RightX > s1.LeftX - sgap And s2.BottomY < s1.TopY + sgap And s2.TopY > s1.BottomY - sgap Then
-          If shft = 1 Or shft = 3 Or shft = 5 Or shft = 7 Then
-            Set isec = s1.Intersect(s2)
-            If Not isec Is Nothing Then
-              arr(i, j) = j
-              isec.CreateSelection
-              isec.Delete
-            End If
-          Else
-            arr(i, j) = j
-          End If
-        End If
-      Next j
-    Next i
-    
-    For i = 1 To gcnt
-      arr = collect_arr(arr, i, i)
-    Next i
-    
-    Set sr = ActiveSelectionRange
-
-    For i = 1 To gcnt
-      sr.RemoveAll
-      inar = 0
-      For j = 1 To gcnt
-        If arr(i, j) > 0 Then
-          sr.Add os.Shapes(j)
-          inar = inar + 1
-        End If
-      Next j
-      If inar > 1 Then
-        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
-      End If
-    Next i
-  Set autogroup = sr_all
-  End If
-
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-  Exit Function
-errn:
-  Application.Optimization = False
-End Function
-
-Public Function collect_arr(arr, ci, ki)
-    lim = UBound(arr)
-    For k = 1 To lim
-        If arr(ki, k) > 0 Then
-            arr(ci, k) = k
-            If ki <> ci Then arr(ki, k) = Empty
-            If ci <> k And ki <> k Then arr = collect_arr(arr, ci, k)
-        End If
-    Next k
-    'If ki <> ci Then arr(ki, ki) = Empty
-    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
@@ -1030,7 +943,7 @@ Public Function Angle_to_Horizon()
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.all
 
-  If nr.Count = 2 Then
+  If nr.count = 2 Then
     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
@@ -1049,7 +962,7 @@ Public Function Auto_Rotation_Angle()
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.all
 
-  If nr.Count = 2 Then
+  If nr.count = 2 Then
     x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
     x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
     a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
@@ -1062,7 +975,7 @@ End Function
 '// 交换对象
 Public Function Exchange_Object()
   Set sr = ActiveSelectionRange
-  If sr.Count = 2 Then
+  If sr.count = 2 Then
     X = sr.LastShape.CenterX: Y = sr.LastShape.CenterY
     sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
     sr.FirstShape.CenterX = X: sr.FirstShape.CenterY = Y
@@ -1076,12 +989,12 @@ Public Function Mirror_ByGuide()
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.all
 
-  If nr.Count >= 2 Then
+  If nr.count >= 2 Then
     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
+    sr.Remove sr.count
     
     ang = 90 - a    '// 镜像的旋转角度
     For Each s In sr
@@ -1112,7 +1025,7 @@ End Function
 
 '// 按面积排列计数
 Public Function Count_byArea(Space_Width As Double)
-  If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.count Then Exit Function
   API.BeginOpt
   ActiveDocument.ReferencePoint = cdrCenter
   
@@ -1149,7 +1062,7 @@ Public Function Count_byArea(Space_Width As Double)
   Dim s1 As Shape
 ' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
   X = ssr.FirstShape.LeftX - 100
-  Y = ssr.FirstShape.TopY
+  Y = ssr.FirstShape.topY
   Set s1 = ActiveLayer.CreateParagraphText(X, Y, X + 90, Y - 150, str, Font:="华文中宋")
 
   API.EndOpt
@@ -1177,7 +1090,7 @@ Private Function Subtotals(str As String) As String
   str = "   规   格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
 
   a = d.keys: b = d.items
-  For i = 0 To d.Count - 1
+  For i = 0 To d.count - 1
     ' Debug.Print a(i), b(i)
     str = str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
   Next

module/savePDFtoClip.bas

@@ -1,15 +1,14 @@
 Attribute VB_Name = "savePDFtoClip"
 #If VBA7 Then
-  Private Declare PtrSafe Function vbadll Lib "lycpg64.cpg" (ByVal code As Long, ByVal x As Double) As Long
+  Private Declare PtrSafe Function vbadll Lib "lycpg64.cpg" (ByVal code As Long, ByVal X As Double) As Long
 #Else
   Private Declare Function vbadll Lib "lycpg32.cpg" (ByVal code As Long, ByVal x As Double) As Long
 #End If
 
 Sub CorelDRAW_CopyPDF()
 '//  savePDFtoClip.CdrCopyToAI
-'// VBA调用CPG_CDR复制物件到AI()
+'// VBA调用CPG_CDR复制物件到AI
  ret = vbadll(2, 0)
- 
 End Sub
 
 Sub CorelDRAW_PastePDF()
@@ -18,6 +17,7 @@ Sub CorelDRAW_PastePDF()
  ret = vbadll(1, 0)
 End Sub
 
+
 Private Function GetTempFile(ByVal sExtension As String) As String
     GetTempFile = CorelScriptTools.GetTempFolder() & "CDR2AI" & "." & sExtension
 End Function
@@ -73,25 +73,20 @@ Public Function AICopyToCdr()
   sTempFilePDF = GetTempFile("pdf")
   '// 调用 clip2pdf.exe 把读取剪贴板保存成PDF
   cmd_line = "C:\TSP\clip2pdf.exe  " & sTempFilePDF
-
+  
   Dim ret As Long
   ret = Shell(cmd_line, vbHide)
   
-  '// 暂停 1 秒 让Shell 调用exe程序完成结果
+  '// 暂停 1/2 秒 让Shell 调用exe程序完成结果
   Dim startTime As Variant
   startTime = Now
-  Do While (Now - startTime) < TimeSerial(0, 0, 1)
+  Do While (Now - startTime) < TimeSerial(0, 0, 1) / 2#
     DoEvents
   Loop
-
-Dim impopt As StructImportOptions
-Set impopt = CreateStructImportOptions
-impopt.MaintainLayers = True
-
-Dim impflt As ImportFilter
-Set impflt = ActiveLayer.ImportEx(sTempFilePDF, cdrAI9, impopt)
-impflt.Finish
-
+  
+  Dim impflt As ImportFilter
+  Set impflt = ActiveLayer.ImportEx(sTempFilePDF, cdrPDF)
+  impflt.Finish
+  
 ErrorHandler:
 End Function
-