蘭雅CorelVBA工具 2024.5.1 永久免费开源开放 lyvba.com

LinesTool/README.md

@@ -0,0 +1,16 @@
+## github开源网址: https://github.com/hongwenjun/vbabox
+
+# vbabox
+
+## 兰雅VBA 线段简易包装盒插件 
+![](https://lyvba.com/wp-content/uploads/2023/08/vbabox3.png)
+
+## 功能介绍
+- 1.选择多个物件的多个节点，点击第一个图标连接成多线段
+- 2.选择多个物件，鼠标左右键加Ctrl，可以不同的排序分别连接多组物件的中心点
+- 3.选择多个物件，按从左到右按顶对齐，鼠标左右键加Ctrl控制物件的间距
+- 4.选择多个物件，按从上到下按左对齐，鼠标左右键加Ctrl控制物件的间距
+- 5.兰雅VBA 线段简易包装盒插件，鼠标左右键加Ctrl，目前有三种样式(如图)
+- 6.选择盒子的顶正侧三面，点击生成简易的3D变形效果
+- 7.2023年9月更新功能: 添加批量旋转移动 镜像 自动间距 转平功能
+

README.md

@@ -1,7 +1,12 @@
 ### [捐赠 蘭雅CorelVBA工具 开源软件](https://github.com/hongwenjun/corelvba/blob/main/donate.md)
 - [![](https://raw.githubusercontent.com/hongwenjun/vps_setup/master/img/youtube.png)频道](https://www.youtube.com/sRGB18/videos)   www.youtube.com/sRGB18   [![](https://raw.githubusercontent.com/hongwenjun/vps_setup/master/img/paypal.png)赞赏支持!](https://paypal.me/sRGB18)  https://paypal.me/sRGB18
 
-## 蘭雅CorelVBA工具 2024.5.1 测试版 永久免费开源开放
+## [蘭雅CorelVBA工具 2024.5.1](https://lyvba.com/LYVBA_2024.7z) 永久免费开源开放 [下载](https://lyvba.com/LYVBA_2024.7z)
+## CorelDRAW Tools - Lanya Corelvba Plug-In For Coreldraw X4-2023   [Download](https://lyvba.com/LYVBA_2024.7z)
+
+## https://youtu.be/WL0EcMo09A0
+
+## https://www.bilibili.com/video/BV1PE42157uM
 
 ![](https://lyvba.com/wp-content/uploads/2024/04/lyvba2024.webp)
 

UI/ArrangeForm.frm

@@ -1,6 +1,6 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ArrangeForm 
-   Caption         =   "蘭雅sRGB 自动拼版 │ 嘉盟赞助"
+   Caption         =   "Matrix Arrange"
    ClientHeight    =   2475
    ClientLeft      =   45
    ClientTop       =   330
@@ -16,7 +16,8 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
-'// 用户窗口初始化
+
+'// 鐢ㄦ埛绐楀彛鍒濆�鍖�
 Private Sub UserForm_Initialize()
   ActiveDocument.Unit = cdrMillimeter
   Dim sr As ShapeRange
@@ -29,12 +30,22 @@ Private Sub UserForm_Initialize()
   TextBox3.text = 0
   TextBox4.text = 0
   
+  LNG_CODE = API.GetLngCode
+  Me.Caption = i18n("Matrix Arrange", LNG_CODE)
+  Me.Frame1.Caption = i18n("Set Matrix", LNG_CODE)
+  Init_Translations Me, LNG_CODE
+  
   Set sr = ActiveSelectionRange
   If sr.Count > 0 Then
     ls = Int(sr.SizeWidth + 0.5)
     hs = Int(sr.SizeHeight + 0.5)
-    Label_Size.Caption = "尺寸: " & ls & "×" & hs & "mm"
     
+    If LNG_CODE = 1033 Then
+      Label_Size.Caption = "Size: " & ls & "x" & hs & "mm"
+    Else
+      Label_Size.Caption = "灏哄�: " & ls & "脳" & hs & "mm"
+    End If
+ 
     lj = Int(pw / ls)
     hj = Int(ph / hs)
     
@@ -57,6 +68,7 @@ Private Sub UserForm_Initialize()
     TextBox1.text = lj
     TextBox2.text = hj
   End If
+  
 End Sub
 
 Private Sub CommandButton1_Click()
@@ -64,39 +76,39 @@ Private Sub CommandButton1_Click()
   API.BeginOpt
   
   Dim ls, hs As Integer: Dim lj, hj As Double
-  Dim matrix As Variant: Dim sr As ShapeRange
+  Dim Matrix As Variant: Dim sr As ShapeRange
   
   ls = Val(TextBox1.text)
   hs = Val(TextBox2.text)
   lj = Val(TextBox3.text)
   hj = Val(TextBox4.text)
-  matrix = Array(ls, hs, lj, hj)
+  Matrix = Array(ls, hs, lj, hj)
   
   Set sr = ActiveSelectionRange
 
   If ls * hs = 0 Then Exit Sub
   If ls = 1 Or hs = 1 Then
-    arrange_Clone_one matrix, sr
+    arrange_Clone_one Matrix, sr
     GoTo ErrorHandler
   End If
   
-  '// 代码运行时关闭窗口刷新
+  '// 浠ｇ爜杩愯�鏃跺叧闂�獥鍙ｅ埛鏂�
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  '// 拼版矩阵
-  arrange_Clone matrix, sr
+  '// 鎷肩増鐭╅樀
+  arrange_Clone Matrix, sr
   Unload Me
   
 ErrorHandler:
   API.EndOpt
 End Sub
 
-'// 拼版矩阵  matrix = Array(ls, hs, lj, hj)
-Private Function arrange_Clone(matrix As Variant, sr As ShapeRange)
-  ls = matrix(0): hs = matrix(1)
-  lj = matrix(2): hj = matrix(3)
+'// 鎷肩増鐭╅樀  matrix = Array(ls, hs, lj, hj)
+Private Function arrange_Clone(Matrix As Variant, sr As ShapeRange)
+  ls = Matrix(0): hs = Matrix(1)
+  lj = Matrix(2): hj = Matrix(3)
   X = sr.SizeWidth: Y = sr.SizeHeight
   Set s1 = sr '// Set s1 = sr.Clone
-  '// StepAndRepeat 方法在范围内创建多个形状副本
+  '// StepAndRepeat 鏂规硶鍦ㄨ寖鍥村唴鍒涘缓澶氫釜褰㈢姸鍓�湰
   
 '//  Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
 '//  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
@@ -107,12 +119,12 @@ Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(ls -
   '// s1.Delete
 End Function
 
-Private Function arrange_Clone_one(matrix As Variant, sr As ShapeRange)
-  ls = matrix(0): hs = matrix(1)
-  lj = matrix(2): hj = matrix(3)
+Private Function arrange_Clone_one(Matrix As Variant, sr As ShapeRange)
+  ls = Matrix(0): hs = Matrix(1)
+  lj = Matrix(2): hj = Matrix(3)
   X = sr.SizeWidth: Y = sr.SizeHeight
   Set s1 = sr '// Set s1 = sr.Clone
-  '// StepAndRepeat 方法在范围内创建多个形状副本
+  '// StepAndRepeat 鏂规硶鍦ㄨ寖鍥村唴鍒涘缓澶氫釜褰㈢姸鍓�湰
   If ls > 1 Then
     Set dup1 = s1.StepAndRepeat(ls - 1, X + lj, 0#)
   Else

UI/CQL_FIND_UI.frm

@@ -13,6 +13,7 @@ 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
 
@@ -57,7 +58,14 @@ Private Sub UserForm_Initialize()
     .Height = 228
   End With
   
-  txtInfo.text = "Usage: A->Left B->Right C->Ctrl"
+  LNG_CODE = API.GetLngCode
+  Init_Translations Me, LNG_CODE
+  
+  If LNG_CODE = 1033 Then
+    txtInfo.text = "Usage: A->Left B->Right C->Ctrl"
+  Else
+    txtInfo.text = "浣跨敤: A->宸﹂敭 B->鍙抽敭 C->Ctrl閿�"
+  End If
 End Sub
 
 Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
@@ -92,7 +100,7 @@ Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, By
 '//   WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
   
-    '// 预置颜色轮廓选择    和 '// 彩蛋功能
+    '// 棰勭疆棰滆壊杞�粨閫夋嫨    鍜� '// 褰╄泲鍔熻兘
   If Abs(X - 178) < 30 And Abs(Y - 118) < 30 = True Then
     Image1.Visible = False
     Close_Icon.Visible = False
@@ -178,7 +186,7 @@ Private Sub CQLSameSize()
     Dim box As Boolean
     box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
     If Not b Then
-      ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
+      ' MsgBox "閫夊尯鑼冨洿: " & x1 & y1 & x2 & y2
       Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
       sh.Shapes.FindShapes(Query:="@width = {" & s.SizeWidth & " mm} and @height ={" & s.SizeHeight & "mm}").CreateSelection
     End If
@@ -194,7 +202,7 @@ Private Sub CQLSameOutlineColor()
   If s Is Nothing Then Exit Sub
   colr.CopyAssign s.Outline.Color
   colr.ConvertToRGB
-  ' 查找对象
+  ' 鏌ユ壘瀵硅薄
   r = colr.RGBRed
   G = colr.RGBGreen
   b = colr.RGBBlue
@@ -209,7 +217,7 @@ Private Sub CQLSameOutlineColor()
     Dim box As Boolean
     box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
     If Not b Then
-      ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
+      ' MsgBox "閫夊尯鑼冨洿: " & x1 & y1 & x2 & y2
       Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
       sh.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
     End If
@@ -219,7 +227,7 @@ Private Sub CQLSameOutlineColor()
   
   Exit Sub
 err:
-    MsgBox "对象轮廓为空。"
+    MsgBox "瀵硅薄杞�粨涓虹┖銆�"
 End Sub
 
 Private Sub CQLSameUniformColor()
@@ -227,10 +235,10 @@ Private Sub CQLSameUniformColor()
   Dim colr As New Color, s As Shape
   Set s = ActiveShape
   If s Is Nothing Then Exit Sub
-  If s.Fill.Type = cdrFountainFill Then MsgBox "不支持渐变色。": Exit Sub
+  If s.Fill.Type = cdrFountainFill Then MsgBox "涓嶆敮鎸佹笎鍙樿壊銆�": Exit Sub
   colr.CopyAssign s.Fill.UniformColor
   colr.ConvertToRGB
-  ' 查找对象
+  ' 鏌ユ壘瀵硅薄
   r = colr.RGBRed
   G = colr.RGBGreen
   b = colr.RGBBlue
@@ -245,7 +253,7 @@ Private Sub CQLSameUniformColor()
     Dim box As Boolean
     box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
     If Not b Then
-      '// MsgBox "选区范围: " & x1 & y1 & x2 & y2
+      '// MsgBox "閫夊尯鑼冨洿: " & x1 & y1 & x2 & y2
       Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
       sh.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
     End If
@@ -254,13 +262,13 @@ Private Sub CQLSameUniformColor()
   End If
   Exit Sub
 err:
-  MsgBox "对象填充为空。"
+  MsgBox "瀵硅薄濉�厖涓虹┖銆�"
 End Sub
 
 Private Sub X_EXIT_Click()
-  Unload Me    '// 关闭
+  Unload Me    '// 鍏抽棴
 End Sub
 
 Private Sub Close_Icon_Click()
-  Unload Me    '// 关闭
+  Unload Me    '// 鍏抽棴
 End Sub

UI/MakeSizePlus.frm

@@ -1,6 +1,6 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MakeSizePlus 
-   Caption         =   "Batch Dimension Plus"
+   Caption         =   "Batch Dimensions Plus"
    ClientHeight    =   3690
    ClientLeft      =   45
    ClientTop       =   330
@@ -13,6 +13,7 @@ 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
 
@@ -35,15 +36,11 @@ Private Const GWL_EXSTYLE = (-20)
 Private Const WS_CAPTION As Long = &HC00000
 Private Const WS_EX_DLGMODALFRAME = &H1&
 
-'// 插件名称 VBA_UserForm
+'// 鎻掍欢鍚嶇О VBA_UserForm
 Private Const TOOLNAME As String = "LYVBA"
 Private Const SECTION As String = "MakeSizePlus"
 Private sreg As New ShapeRange
 
-Private Sub Frame1_Click()
-
-End Sub
-
 Private Sub UserForm_Initialize()
   With Me
     .StartUpPosition = 0
@@ -53,23 +50,23 @@ Private Sub UserForm_Initialize()
     .Height = Val(GetSetting(TOOLNAME, SECTION, "form_Height", 105))
   End With
 
-  LNG_CODE = Val(GetSetting("LYVBA", "Settings", "I18N_LNG", "1033"))
+  LNG_CODE = API.GetLngCode
   Init_Translations Me, LNG_CODE
-  Me.Caption = i18n("Batch Dimension Plus", LNG_CODE)
+  Me.Caption = i18n("Batch Dimensions Plus", LNG_CODE)
   
-   ' 读取线设置
+   ' 璇诲彇绾胯�缃�
   Bleed.text = API.GetSet("Bleed")
   Line_len.text = API.GetSet("Line_len")
   Outline_Width.text = GetSetting("LYVBA", "Settings", "Outline_Width", "0.2")
-  
+
 End Sub
 
-'// 关闭窗口时保存窗口位置
+'// 鍏抽棴绐楀彛鏃朵繚瀛樼獥鍙ｄ綅缃�
 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
     saveFormPos True
 End Sub
 
-'// 保存窗口位置和加载窗口位置
+'// 淇濆瓨绐楀彛浣嶇疆鍜屽姞杞界獥鍙ｄ綅缃�
 Sub saveFormPos(bDoSave As Boolean)
   If bDoSave Then 'save position
     SaveSetting TOOLNAME, SECTION, "form_left", Me.Left
@@ -92,7 +89,7 @@ Private Sub btn_ExpandForm_Click()
 End Sub
 
 
-'// Minimizes the window and retains dimensioning functionality   '// 最小化窗口并保留标注尺寸功能
+'// Minimizes the window and retains dimensioning functionality   '// 鏈€灏忓寲绐楀彛骞朵繚鐣欐爣娉ㄥ昂瀵稿姛鑳�
 Private Function MiniForm()
 
   Dim IStyle As Long
@@ -107,7 +104,7 @@ Private Function MiniForm()
   IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
   SetWindowLong hwnd, GWL_EXSTYLE, IStyle
 
-  Dim ctl As Variant  '// CorelDRAW 2020 定义成 Variant 才不会错误
+  Dim ctl As Variant  '// CorelDRAW 2020 瀹氫箟鎴� Variant 鎵嶄笉浼氶敊璇�
   For Each ctl In MakeSizePlus.Controls
       ctl.Visible = False
       ctl.Top = 2
@@ -144,7 +141,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
-   Call API.Set_Space_Width  '// 设置空间间隙
+   Call API.Set_Space_Width  '// 璁剧疆绌洪棿闂撮殭
   End If
 End Sub
 
@@ -203,7 +200,7 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
   
   Dim border As Variant
   Dim Line_len As Double
-  Line_len = API.Set_Space_Width(True)  '// 读取间隔
+  Line_len = API.Set_Space_Width(True)  '// 璇诲彇闂撮殧
 
   border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + Line_len, os.TopY + 2 * Line_len, _
   cdrBottomRight, cdrTopRight, os.LeftX - Line_len, os.LeftX - 2 * Line_len)
@@ -274,7 +271,7 @@ Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = Fal
             Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopRight)
             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
         'ActiveDocument.ClearSelection
       Next i
@@ -372,12 +369,12 @@ ErrorHandler:
   API.EndOpt
 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
   
-  '// 右键
+  '// 鍙抽敭
   If Button = 2 Then
     If chkOpposite.value = True Then
         CutLines.Dimension_MarkLines cdrAlignTop, True
@@ -387,7 +384,7 @@ Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As I
       make_sizes_sep "lfbx", Shift, True
     End If
   
-  '// 左键
+  '// 宸﹂敭
   ElseIf Button = 1 Then
     If chkOpposite.value = True Then
       CutLines.Dimension_MarkLines cdrAlignLeft, False
@@ -401,18 +398,18 @@ Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As I
   sr.CreateSelection
 End Sub
 
-'// 使用手工选节点建立尺寸标注，使用Ctrl分离尺寸标注
+'// 浣跨敤鎵嬪伐閫夎妭鐐瑰缓绔嬪昂瀵告爣娉�紝浣跨敤Ctrl鍒嗙�灏哄�鏍囨敞
 Private Sub Manual_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-      '// 右键
+      '// 鍙抽敭
   ElseIf Shift = fmCtrlMask Then
-      Slanted_Makesize  '// 手动标注倾斜尺寸
+      Slanted_Makesize  '// 鎵嬪姩鏍囨敞鍊炬枩灏哄�
   Else
-      ModulePlus.Untie_MarkLines   '// 解绑尺寸，分离尺寸
+      ModulePlus.Untie_MarkLines   '// 瑙ｇ粦灏哄�锛屽垎绂诲昂瀵�
   End If
 End Sub
 
-'// 手动标注倾斜尺寸
+'// 鎵嬪姩鏍囨敞鍊炬枩灏哄�
 Private Function Slanted_Makesize()
   On Error GoTo ErrorHandler
   API.BeginOpt
@@ -425,7 +422,7 @@ Private Function Slanted_Makesize()
   Set nr = ActiveShape.Curve.Selection
   
   If chkOpposite.value = False Then
-    Slanted_Sort_Make sr  '// 排序标注倾斜尺寸
+    Slanted_Sort_Make sr  '// 鎺掑簭鏍囨敞鍊炬枩灏哄�
     Exit Function
   End If
   If nr.Count < 2 Then Exit Function
@@ -449,7 +446,7 @@ ErrorHandler:
   API.EndOpt
 End Function
 
-'// 排序标注倾斜尺寸
+'// 鎺掑簭鏍囨敞鍊炬枩灏哄�
 Private Function Slanted_Sort_Make(shs As ShapeRange)
   On Error GoTo ErrorHandler
   Dim sr As New ShapeRange
@@ -463,7 +460,7 @@ Private Function Slanted_Sort_Make(shs As ShapeRange)
     Next n
   Next sh
   
-  CutLines.RemoveDuplicates sr  '// 简单删除重复算法
+  CutLines.RemoveDuplicates sr  '// 绠€鍗曞垹闄ら噸澶嶇畻娉�
   Set sr = X4_Sort_ShapeRange(sr, stlx)
 
   For i = 1 To sr.Count - 1
@@ -488,15 +485,15 @@ ErrorHandler:
   API.EndOpt
 End Function
 
-'// 尺寸标注设置属性
+'// 灏哄�鏍囨敞璁剧疆灞炴€�
 Private Function Dimension_SetProperty(sh_dim As Shape, Optional ByVal Preset As Boolean = False)
 #If VBA7 Then
   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 "dynamicText", 0 '    是否可以编辑尺寸0/1
+      .SetProperty "precision", 0 '       灏忔暟浣嶆暟
+      .SetProperty "showUnits", 0 '       鏄�惁鏄剧ず鍗曚綅 0/1
+      .SetProperty "textPlacement", 0 '   0銆佷笂鏂癸紝1銆佷笅鏂癸紝2銆佷腑闂�
+    '  .SetProperty "dynamicText", 0 '    鏄�惁鍙�互缂栬緫灏哄�0/1
     '  .SetProperty "overhang", 500000 '
     End With
   End If
@@ -507,7 +504,7 @@ Private Function Dimension_SetProperty(sh_dim As Shape, Optional ByVal Preset As
 #End If
 End Function
 
-'// 尺寸标注左边
+'// 灏哄�鏍囨敞宸﹁竟
 Private Sub Makesize_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignLeft, False
@@ -522,7 +519,7 @@ Private Sub Makesize_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
   End If
 End Sub
 
-'// 尺寸标注右边
+'// 灏哄�鏍囨敞鍙宠竟
 Private Sub Makesize_Right_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignLeft, True
@@ -538,7 +535,7 @@ Private Sub Makesize_Right_MouseUp(ByVal Button As Integer, ByVal Shift As Integ
 
 End Sub
 
-'// 尺寸标注向上
+'// 灏哄�鏍囨敞鍚戜笂
 Private Sub Makesize_Up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignTop, False
@@ -553,7 +550,7 @@ Private Sub Makesize_Up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer,
   End If
 End Sub
 
-'// 尺寸标注向下
+'// 灏哄�鏍囨敞鍚戜笅
 Private Sub Makesize_Down_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
     CutLines.Dimension_MarkLines cdrAlignTop, True
@@ -573,16 +570,16 @@ Private Sub MakeRuler_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, B
   API.BeginOpt
   Set sreg = Nothing
   
-  If Button = 2 And Shift = 0 Then       '// 鼠标右键 标注右边
+  If Button = 2 And Shift = 0 Then       '// 榧犳爣鍙抽敭 鏍囨敞鍙宠竟
     Ruler_Align cdrAlignRight
     
-  ElseIf Button = 2 And Shift = 2 Then  '// Ctrl+鼠标右键 标注左边
+  ElseIf Button = 2 And Shift = 2 Then  '// Ctrl+榧犳爣鍙抽敭 鏍囨敞宸﹁竟
     Ruler_Align cdrAlignLeft
  
-  ElseIf Shift = 0 Then    '// 鼠标左键，标注在上边
+  ElseIf Shift = 0 Then    '// 榧犳爣宸﹂敭锛屾爣娉ㄥ湪涓婅竟
     Ruler_Align cdrAlignTop
     
-  ElseIf Shift = 2 Then  '// Ctrl+鼠标左键，标注下边
+  ElseIf Shift = 2 Then  '// Ctrl+榧犳爣宸﹂敭锛屾爣娉ㄤ笅杈�
     Ruler_Align cdrAlignBottom
   End If
   
@@ -598,7 +595,7 @@ Private Sub MakeRuler_Align_MouseUp(ByVal Button As Integer, ByVal Shift As Inte
    
   Dim ra As cdrAlignType
   ra = cdrAlignTop
-  ' 定义方向上下左右
+  ' 瀹氫箟鏂瑰悜涓婁笅宸﹀彸
   Dim pos_x As Variant, pos_y As Variant
   pos_x = Array(27, 27, 12, 44)
   pos_y = Array(12, 44, 27, 27)
@@ -619,22 +616,22 @@ ErrorHandler:
 End Sub
 
 Private Function Ruler_Align(ra As cdrAlignType)
-  If ra = cdrAlignRight Then       '// 标注右边
+  If ra = cdrAlignRight Then       '// 鏍囨敞鍙宠竟
     CutLines.Dimension_MarkLines cdrAlignLeft, True
     Add_Ruler_Text_Y True
-  ElseIf ra = cdrAlignLeft Then  '// 标注左边
+  ElseIf ra = cdrAlignLeft Then  '// 鏍囨敞宸﹁竟
     CutLines.Dimension_MarkLines cdrAlignLeft, False
     Add_Ruler_Text_Y True
-  ElseIf ra = cdrAlignTop Then    '// 标注上边
+  ElseIf ra = cdrAlignTop Then    '// 鏍囨敞涓婅竟
     CutLines.Dimension_MarkLines cdrAlignTop, False
     Add_Ruler_Text True
-  ElseIf ra = cdrAlignBottom Then  '// 标注下边
+  ElseIf ra = cdrAlignBottom Then  '// 鏍囨敞涓嬭竟
     CutLines.Dimension_MarkLines cdrAlignTop, True
     Add_Ruler_Text True
   End If
 End Function
 
-  '// 标尺线转换成距离数字
+  '// 鏍囧昂绾胯浆鎹㈡垚璺濈�鏁板瓧
 Private Function Add_Ruler_Text(rm_lines As Boolean)
   On Error GoTo ErrorHandler
   API.BeginOpt
@@ -656,7 +653,7 @@ ErrorHandler:
   API.EndOpt
 End Function
 
-  '// 标尺线转换成距离数字
+  '// 鏍囧昂绾胯浆鎹㈡垚璺濈�鏁板瓧
 Private Function Add_Ruler_Text_Y(rm_lines As Boolean)
   On Error GoTo ErrorHandler
   API.BeginOpt
@@ -685,14 +682,15 @@ Private Sub X_EXIT_Click()
 End Sub
 
 Private Sub I18N_LNG_Click()
-  LNG_CODE = Val(GetSetting("LYVBA", "Settings", "I18N_LNG", "1033"))
+  LNG_CODE = API.GetLngCode
   If LNG_CODE = 1033 Then
     LNG_CODE = 2052
   Else
     LNG_CODE = 1033
   End If
   SaveSetting "LYVBA", "Settings", "I18N_LNG", LNG_CODE
-  MsgBox "中英文语言切换完成，请重启插件!", vbOKOnly, "兰雅VBA代码分享"
+  LNG_CODE = API.GetLngCode
+  MsgBox i18n("Chinese And English Language Switching Is Completed, Please Restart The Plug-In.", LNG_CODE), vbOKOnly, i18n("Lanya Corelvba Plug-In", LNG_CODE)
 End Sub
 
 
@@ -708,18 +706,18 @@ Private Sub btn_square_wi_Click()
   ModulePlus.square_hw "Width"
 End Sub
 
-'// 节点连接合并
+'// 鑺傜偣杩炴帴鍚堝苟
 Private Sub btn_join_nodes_Click()
     ActiveSelection.CustomCommand "ConvertTo", "JoinCurves"
     Application.Refresh
 End Sub
 
-'// 节点优化减少
+'// 鑺傜偣浼樺寲鍑忓皯
 Private Sub btn_nodes_reduce_Click()
   ModulePlus.Nodes_Reduce
 End Sub
 
-'// 选择标注线 选择文字 删除或者解绑标准线
+'// 閫夋嫨鏍囨敞绾� 閫夋嫨鏂囧瓧 鍒犻櫎鎴栬€呰В缁戞爣鍑嗙嚎
 Private Sub SelectText_Click()
   ModulePlus.Dimension_Select_or_Delete 4
 End Sub

UI/Make_SIZE.frm

@@ -1,28 +1,40 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Make_SIZE 
+   Caption         =   "Make Size Simple"
+   ClientHeight    =   1515
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   3690
+   OleObjectBlob   =   "Make_SIZE.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
 Attribute VB_Name = "Make_SIZE"
 Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
-
-
 Private Sub UserForm_Initialize()
     With Tis
         .BackColor = RGB(0, 150, 255)
         .BorderColor = RGB(30, 150, 255)
         .ForeColor = RGB(255, 255, 255)
     End With
+    
+  LNG_CODE = API.GetLngCode
+  Me.Caption = i18n("Make Size Simple", LNG_CODE)
+  Init_Translations Me, LNG_CODE
 End Sub
 
-Private Function 按钮移入(T)
-    With T
+Private Function button_move_in(t)
+    With t
         .BackColor = RGB(0, 150, 255)
         .BorderColor = RGB(30, 150, 255)
         .ForeColor = RGB(255, 255, 255)
     End With
 End Function
 
-Private Function 命令按钮(T As Label)
-    With T
+Private Function command_button(t As Label)
+    With t
         .BackColor = RGB(240, 240, 240)
         .BorderColor = RGB(100, 100, 100)
         .ForeColor = RGB(0, 0, 0)
@@ -46,42 +58,42 @@ Private Sub CheckBox4_Click()
 End Sub
 
 Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
-    Call 命令按钮(标注)
-    Call 命令按钮(删除)
+    Call command_button(bt_MakeSize)
+    Call command_button(bt_Del)
 End Sub
 
 Private Sub SpinButton1_SpinDown()
-    选中标注字号减少
+    Select_Font_Sub_Size
 End Sub
 
 Private Sub SpinButton1_SpinUp()
-    选中标注字号增加
+    Select_Font_Add_Size
 End Sub
 
 Private Sub TextBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
-    选中标注字号
+    Select_Font_Size
 End Sub
 
-Private Sub 标注_Click()
-    If CheckBox1 Or CheckBox2 Then Call 标注宽高度
-    If CheckBox3 Then Call 标注线长
-    If CheckBox4 Then Call 标注线段长
+Private Sub bt_MakeSize_Click()
+    If CheckBox1 Or CheckBox2 Then Call Dimension_width_and_height
+    If CheckBox3 Then Call Mark_line_length
+    If CheckBox4 Then Call Dimension_line_length
 End Sub
 
-Private Sub 标注_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
-    Call 按钮移入(标注)
+Private Sub bt_MakeSize_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    Call button_move_in(bt_MakeSize)
 End Sub
 
-Private Sub 删除_Click()
-    删除标注
+Private Sub bt_Del_Click()
+    Delete_callout
 End Sub
 
-Private Sub 删除_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
-    Call 按钮移入(删除)
+Private Sub bt_Del_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    Call button_move_in(bt_Del)
 End Sub
 
 
-Private Sub 标注宽高度()
+Private Sub Dimension_width_and_height()
     ActiveDocument.Unit = cdrMillimeter
     Dim s As Shape, st1 As Shape, st2 As Shape
     Set s = ActiveShape
@@ -89,38 +101,38 @@ Private Sub 标注宽高度()
     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" ' 设置名
+                st1.name = "Text" ' 设置名
             Set sox = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY + 3, s.RightX, s.TopY + 3)
                 sox.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
-                sox.Name = "line"
+                sox.name = "line"
             Set sox1 = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY + 1, s.LeftX, s.TopY + 3)
                 sox1.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
-                sox1.Name = "line"
+                sox1.name = "line"
             Set sox2 = ActiveLayer.CreateLineSegment(s.RightX, s.TopY + 1, s.RightX, s.TopY + 3)
                 sox2.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
-                sox2.Name = "line"
+                sox2.name = "line"
             s.CreateSelection
         End If
         If CheckBox2 Then
-            Set st2 = ActiveLayer.CreateArtisticText(s.LeftX - 4, s.BottomY, round(s.SizeHeight, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrCenterAlignment)
+            Set st2 = ActiveLayer.CreateArtisticText(s.LeftX - 4, s.BottomY, Round(s.SizeHeight, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrCenterAlignment)
             st2.text.Story.CharSpacing = 0 '字符间距
             st2.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
             st2.Rotate 90
             st2.Move -st2.SizeWidth / 2, s.SizeHeight / 2
-            st2.Name = "Text" ' 设置名
+            st2.name = "Text" ' 设置名
             Set soy = ActiveLayer.CreateLineSegment(s.LeftX - 3, s.BottomY, s.LeftX - 3, s.TopY)
                 soy.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
-                soy.Name = "line"
+                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"
+                soy1.name = "line"
             Set soy2 = ActiveLayer.CreateLineSegment(s.LeftX - 1, s.TopY, s.LeftX - 3, s.TopY)
                 soy2.Outline.Color.RGBAssign 40, 170, 20 ' 填充颜色
-                soy2.Name = "line"
+                soy2.name = "line"
             s.CreateSelection
         End If
     Next
@@ -128,7 +140,7 @@ Private Sub 标注宽高度()
     ActiveWindow.Refresh '刷新文档窗口
 End Sub
 
-Private Sub 标注线段长()
+Private Sub Dimension_line_length()
     ActiveDocument.Unit = cdrMillimeter
     Dim s As Shape, s1 As Shape, s2 As Shape, sc As Shape, st1 As Shape, st2 As Shape
     Set s = ActiveShape
@@ -142,7 +154,7 @@ Private Sub 标注线段长()
             sc.Curve.Nodes.all.BreakApart
             sc.BreakApart
             For Each s1 In ActiveSelection.Shapes
-                Set st1 = ActiveLayer.CreateArtisticText(0, 0, round(s1.Curve.Length, 0), , , , TextBox1.value)
+                Set st1 = ActiveLayer.CreateArtisticText(0, 0, Round(s1.Curve.Length, 0), , , , TextBox1.value)
                 st1.text.Story.CharSpacing = 0 '字符间距
                 st1.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
                 st1.text.FitToPath s1
@@ -150,22 +162,22 @@ Private Sub 标注线段长()
                 st1.Effects(1).TextOnPath.Offset = s1.Curve.Length * 0.5 - st1.SizeWidth * 0.55
                 ' 获取或设置文本与路径的距离
                 st1.Effects(1).TextOnPath.DistanceFromPath = 1
-                st1.Name = "Text" ' 设置名
+                st1.name = "Text" ' 设置名
                 s1.Outline.SetNoOutline
                 s1.OrderToBack
-                s1.Name = "line"
+                s1.name = "line"
             Next
             Set st2 = ActiveLayer.CreateArtisticText(s.RightX + 3, s.BottomY, "单位：mm", , , "微软雅黑", TextBox1.value)
             st2.text.Story.CharSpacing = 0 '字符间距
             st2.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
-            st2.Name = "Text" ' 设置名
+            st2.name = "Text" ' 设置名
          End If
     Next
     Optimization = False '优化关闭
     ActiveWindow.Refresh '刷新文档窗口
 End Sub
 
-Private Sub 标注线长()
+Private Sub Mark_line_length()
     ActiveDocument.Unit = cdrMillimeter
     Dim s As Shape, st1 As Shape
     Set s = ActiveShape
@@ -175,11 +187,11 @@ Private Sub 标注线长()
         If s.Type <> cdrTextShape Then
             X = s.LeftX
             Y = s.BottomY
-            Set st1 = ActiveLayer.CreateArtisticText(X, Y, "线条长：" & round(s.DisplayCurve.Length, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrLeftAlignment)
+            Set st1 = ActiveLayer.CreateArtisticText(X, Y, "线条长：" & Round(s.DisplayCurve.Length, 0) & "mm", , , "微软雅黑", TextBox1.value, , , , cdrLeftAlignment)
             st1.text.Story.CharSpacing = 0 '字符间距
             st1.Fill.UniformColor.RGBAssign 40, 170, 20 ' 填充颜色
             st1.Move 0, -st1.SizeHeight * 2
-            st1.Name = "Text" ' 设置名
+            st1.name = "Text" ' 设置名
             s.CreateSelection
         End If
     Next
@@ -187,7 +199,7 @@ Private Sub 标注线长()
     ActiveWindow.Refresh '刷新文档窗口
 End Sub
 
-Private Sub 选中标注字号增加()
+Private Sub Select_Font_Add_Size()
     Dim s As Shape
     Optimization = True '优化启动
     If TextBox1.value > 0 Then
@@ -200,7 +212,7 @@ Private Sub 选中标注字号增加()
     ActiveWindow.Refresh '刷新文档窗口
 End Sub
 
-Private Sub 选中标注字号减少()
+Private Sub Select_Font_Sub_Size()
     Dim s As Shape
     Optimization = True '优化启动
     If TextBox1.value > 0 Then
@@ -213,7 +225,7 @@ Private Sub 选中标注字号减少()
     ActiveWindow.Refresh '刷新文档窗口
 End Sub
 
-Private Sub 选中标注字号()
+Private Sub Select_Font_Size()
     Dim s As Shape
     Optimization = True '优化启动
     If TextBox1.value > 0 Then
@@ -225,7 +237,7 @@ Private Sub 选中标注字号()
     ActiveWindow.Refresh '刷新文档窗口
 End Sub
 
-Private Sub 删除标注()
+Private Sub Delete_callout()
     If ActiveSelection.Shapes.Count > 0 Then
         ActiveSelection.Shapes.FindShapes(Query:="@type ='text:artistic' and @Name='Text' ").Delete
         ActiveSelection.Shapes.FindShapes(Query:="@Name='line' ").Delete
@@ -235,3 +247,4 @@ Private Sub 删除标注()
     End If
 End Sub
 
+

UI/PhotoForm.frm

@@ -1,3 +1,22 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} PhotoForm 
+   Caption         =   "Batch Convert Img Or Export JPEG"
+   ClientHeight    =   1755
+   ClientLeft      =   45
+   ClientTop       =   375
+   ClientWidth     =   3855
+   OleObjectBlob   =   "PhotoForm.frx":0000
+   ShowModal       =   0   'False
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "PhotoForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+
+
 Private Sub UserForm_Initialize()
     On Error Resume Next
     ComboBox1.AddItem "灰度"
@@ -75,13 +94,14 @@ Private Sub Export_JPEG_Click()
     opt.ResolutionY = dpi
     opt.ImageType = Color
     
+    Dim path$: path = CorelScriptTools.GetFolder
     '// 批处理导出图片
     For Each sh In shs
         ActiveDocument.ClearSelection
         sh.CreateSelection
 
         ' 导出图片 JPEG格式
-        f = d.FilePath & "Link_" & sh.StaticID & ".jpg"
+        f = path & "\" & d.FileName & "_ID" & sh.StaticID & ".jpg"
         d.Export f, cdrJPEG, cdrSelection, opt
     Next sh
 End Sub

UI/Replace_UI.frm

@@ -1,6 +1,5 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Replace_UI 
-   Caption         =   "使剪贴板上的物件替换选择的目标物件"
    ClientHeight    =   4560
    ClientLeft      =   45
    ClientTop       =   330
@@ -15,6 +14,7 @@ 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
@@ -36,7 +36,7 @@ Private Const WS_EX_DLGMODALFRAME = &H1&
 
 
 Private Sub Close_Icon_Click()
-  Unload Me    '// 关闭
+  Unload Me    '// 鍏抽棴
 End Sub
 
 Private Sub UserForm_Initialize()
@@ -59,7 +59,9 @@ Private Sub UserForm_Initialize()
     .width = 378
     .Height = 228
   End With
-  
+
+  LNG_CODE = API.GetLngCode
+  Init_Translations Me, LNG_CODE
 End Sub
 
 Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
@@ -128,7 +130,7 @@ Private Sub image_replace()
   Next sh
 
 ErrorHandler:
-'//    MsgBox "请先复制图片的完整路径，本工具能自动替换图片!"
+'//    MsgBox "璇峰厛澶嶅埗鍥剧墖鐨勫畬鏁磋矾寰勶紝鏈�伐鍏疯兘鑷�姩鏇挎崲鍥剧墖!"
   API.EndOpt
 End Sub
 
@@ -158,7 +160,7 @@ Private Sub copy_shape_replace_resize()
   Next sh
 
 ErrorHandler:
-'// MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
+'// MsgBox "璇峰厛澶嶅埗Ctrl+C锛岀劧鍚庨€夋嫨瑕佹浛鎹㈢殑鐗╀欢杩愯�鏈�伐鍏�!"
   API.EndOpt
 End Sub
 
@@ -185,7 +187,7 @@ Private Sub copy_shape_replace()
   Next sh
 
 ErrorHandler:
-'// MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
+'// MsgBox "璇峰厛澶嶅埗Ctrl+C锛岀劧鍚庨€夋嫨瑕佹浛鎹㈢殑鐗╀欢杩愯�鏈�伐鍏�!"
   API.EndOpt
 End Sub
 

UI/Toolbar.frm

@@ -12,6 +12,7 @@ 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
 
@@ -68,18 +69,24 @@ End Sub
 
 Private Sub Change_UI_Close_Voice_Click()
   SaveSetting "LYVBA", "Settings", "SpeakHelp", "0"
-  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA工具 永久免费开源"
+  LNG_CODE = API.GetLngCode
+  If LNG_CODE = 1033 Then
+    MsgBox "Thanks For Your Support!" & vbNewLine & "Lanya Corelvba Tool Permanently Free And Open Source"
+  Else
+    MsgBox "璇风粰鎴戞敮鎸�!" & vbNewLine & "鎮ㄧ殑鏀�寔锛屾垜鎵嶈兘鏈夊姩鍔涙坊鍔犳洿澶氬姛鑳�." & vbNewLine & "铇�泤CorelVBA宸ュ叿 姘镐箙鍏嶈垂寮€婧�"
+  End If
 End Sub
 
 Private Sub I18N_LNG_Click()
-  LNG_CODE = Val(GetSetting("LYVBA", "Settings", "I18N_LNG", "1033"))
+  LNG_CODE = API.GetLngCode
   If LNG_CODE = 1033 Then
     LNG_CODE = 2052
   Else
     LNG_CODE = 1033
   End If
   SaveSetting "LYVBA", "Settings", "I18N_LNG", LNG_CODE
-  MsgBox "中英文语言切换完成，请重启插件!", vbOKOnly, "兰雅VBA代码分享"
+  LNG_CODE = API.GetLngCode
+  MsgBox i18n("Chinese And English Language Switching Is Completed, Please Restart The Plug-In.", LNG_CODE), vbOKOnly, i18n("Lanya Corelvba Plug-In", LNG_CODE)
 End Sub
 
 Private Sub UserForm_Initialize()
@@ -97,7 +104,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
@@ -106,28 +113,28 @@ 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"
+  UIFile = path & "GMS\LYVBA\" & HDPI.GetHDPIPercentage & "\ToolBar.jpg"
   If API.ExistsFile_UseFso(UIFile) Then
-    UI.Picture = LoadPicture(UIFile)   '换UI图
+    UI.Picture = LoadPicture(UIFile)   '鎹�I鍥�
     Set pic1 = LoadPicture(UIFile)
   End If
 
-  UIL = Path & "GMS\LYVBA\ToolBar1.jpg"
+  UIL = path & "GMS\LYVBA\ToolBar1.jpg"
   If API.ExistsFile_UseFso(UIL) Then
     Set pic2 = LoadPicture(UIL)
     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
 
@@ -173,7 +180,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
 
@@ -186,152 +193,152 @@ 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和CorelDRAW 缩略图工具
+      '// Adobe AI EPS INDD PDF鍜孋orelDRAW 缂╃暐鍥惧伐鍏�
       AdobeThumbnail_Click
       
     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
       
     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
       
     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
     
   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
@@ -341,54 +348,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
 
@@ -414,7 +421,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
 
@@ -439,7 +446,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
@@ -459,8 +466,14 @@ End Sub
 
 Private Sub OPEN_UI_BIG_Click()
   Unload Me
-  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA工具 永久免费开源" _
-       & vbNewLine & "源码网址:" & vbNewLine & "https://github.com/hongwenjun/corelvba"
+  LNG_CODE = API.GetLngCode
+  If LNG_CODE = 1033 Then
+    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"
+  End If
 End Sub
 
 Private Sub Settings_Click()
@@ -470,7 +483,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
   
@@ -478,16 +491,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 "左键拆分线段，Ctrl合并线段"
+    MsgBox "宸﹂敭鎷嗗垎绾挎�锛孋trl鍚堝苟绾挎�"
   ElseIf Shift = fmCtrlMask Then
     Tools.Split_Segment
   Else
@@ -495,10 +508,10 @@ Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
     Application.Refresh
   End If
   
-  Speak_Msg "拆分线段，Ctrl合并线段"
+  Speak_Msg "鎷嗗垎绾挎�锛孋trl鍚堝苟绾挎�"
 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
@@ -508,11 +521,11 @@ Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As
   
   If Button Then
     value = GMSManager.RunMacro("AIClipboard", "CopyPaste.CopyAIFormat")
-    MsgBox "CorelDRAW 与 Adobe_Illustrator 剪贴板转换" & vbNewLine & "鼠标左键复制，鼠标右键粘贴"
+    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
@@ -521,10 +534,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
@@ -535,7 +548,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
@@ -546,7 +559,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#
@@ -557,7 +570,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#
@@ -569,28 +582,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和CorelDRAW 缩略图工具  ////'''
+'''////  Adobe AI EPS INDD PDF鍜孋orelDRAW 缂╃暐鍥惧伐鍏�  ////'''
 Private Sub AdobeThumbnail_Click()
     Dim h As Long, r As Long
-    mypath = Path & "GMS\LYVBA\"
+    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
@@ -601,42 +614,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
 
-'// 标准尺寸，左键右键Ctrl三键控制，调用三种样式
+'// 鏍囧噯灏哄�锛屽乏閿�彸閿瓹trl涓夐敭鎺у埗锛岃皟鐢ㄤ笁绉嶆牱寮�
 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
@@ -662,7 +675,7 @@ Private Sub SwapShape_Click()
 End Sub
 
 
-'// 小工具快速启动
+'// 灏忓伐鍏峰揩閫熷惎鍔�
 Private Sub Open_Calc_Click()
   Launcher.START_Calc
 End Sub

UI/UniteOne.frm

@@ -1,130 +1,55 @@
-Option Explicit
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} UniteOne 
+   Caption         =   "Merge Multiple Pages Into One"
+   ClientHeight    =   4005
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   5220
+   OleObjectBlob   =   "UniteOne.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "UniteOne"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
 #If VBA7 Then
-    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 #Else
-    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 #End If
 
- Dim iHang, iLie, iPages As Integer     '定义行数(Y) 列数(X)
- Dim iYouyi, iXiayi As Single   '右移(R) 下移(B)
-                                'txtHang, txtLie, txtYouyi, txtXiayi ,txtInfo
- Dim LogoFile As String         'Logo
- 
- Dim s(1 To 255) As Shape   '定义对象用于存放每页的群组
- Dim P As Page          '定义多页
- 
-
-'**** 主程序  执行
-Private Sub cmdRun_Click()
-  '// 代码运行时关闭窗口刷新
-  Application.Optimization = True
-  ActiveDocument.BeginCommandGroup  '一步撤消'
-
- Dim x_M, y_M
- ActiveDocument.Unit = cdrMillimeter
- ActiveDocument.EditAcrossLayers = False    '跨图层编辑禁止
- 
- For Each P In ActiveDocument.Pages
-    P.Activate                    '激活每页
-    P.Shapes.all.CreateSelection          '每页全选
-    Set s(P.index) = ActiveSelection.Group    '存放每页的群组
- Next P
- 
- ActiveDocument.EditAcrossLayers = True     '跨图层编辑开启
- 
-  x_M = y_M = 0
-  
-  For Each P In ActiveDocument.Pages
-    P.Activate
-       
-    s(P.index).MoveToLayer ActivePage.DesktopLayer    '每页对象移动到桌面层
-    s(P.index).Move (iYouyi * x_M), -(300 + iXiayi * y_M) '排列对象  右偏移，下偏移
-  
-  y_M = y_M + 1
-  
-  If y_M = iLie Then
-  x_M = x_M + 1
-  y_M = 0
-  End If
-  
- Next P
- 
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh
-  Application.Refresh
- Unload Me '执行完成关闭
-End Sub
-
-
-'**** 主程序 副本 横排序
-Private Sub cmdRunX_Click()
-  '// 代码运行时关闭窗口刷新
-  Application.Optimization = True
-  ActiveDocument.BeginCommandGroup  '一步撤消'
+Dim iHang, iLie, iPages As Integer     '// 定义行数(Y) 列数(X)
+Dim iYouyi, iXiayi As Single           '// 右移(R) 下移(B)
+                                       '// txtHang, txtLie, txtYouyi, txtXiayi ,txtInfo
+Dim LogoFile As String                 '// Logo
 
- Dim x_M, y_M
- ActiveDocument.Unit = cdrMillimeter
- ActiveDocument.EditAcrossLayers = False    '跨图层编辑禁止
+Dim s(1 To 255) As Shape   '// 定义对象用于存放每页的群组
+Dim P As Page              '// 定义多页
  
- For Each P In ActiveDocument.Pages
-    P.Activate                    '激活每页
-    P.Shapes.all.CreateSelection          '每页全选
-    Set s(P.index) = ActiveSelection.Group    '存放每页的群组
- Next P
- 
- ActiveDocument.EditAcrossLayers = True     '跨图层编辑开启
- 
-  x_M = y_M = 0
+'// *********** 初始化程序 ***************
+Private Sub UserForm_Initialize()
+  Dim s As Shape
+  ActiveDocument.Unit = cdrMillimeter '// 本文档单位为mm
   
   For Each P In ActiveDocument.Pages
-    P.Activate
-       
-    s(P.index).MoveToLayer ActivePage.DesktopLayer    '每页对象移动到桌面层
-    s(P.index).Move (iYouyi * y_M), -(600 + iXiayi * x_M) '排列对象  右偏移，下偏移
-  
-  y_M = y_M + 1
-  
-  If y_M = iHang Then
-  x_M = x_M + 1
-  y_M = 0
-  End If
-  
- Next P
- 
-  ActiveDocument.EndCommandGroup
-  Application.Optimization = False
-  ActiveWindow.Refresh
-  Application.Refresh
- 
- Unload Me '执行完成关闭
-End Sub
-
-
-'*********** 初始化程序 ***************
-Private Sub UserForm_Initialize()
-
- Dim s As Shape
-ActiveDocument.Unit = cdrMillimeter '本文档单位为mm
-
- For Each P In ActiveDocument.Pages
- iPages = P.index
- If iPages = 1 Then
-  P.Activate
-  P.Shapes.all.CreateSelection
-
- Set s = ActiveDocument.Selection
-        If s.Shapes.Count = 0 Then
-            MsgBox "当前文件第一页空白没有物件！"
-            Exit Sub
-        End If
- 
- End If
- Next P
+    iPages = P.index
+    If iPages = 1 Then
+      P.Activate
+      P.Shapes.all.CreateSelection
+      
+      Set s = ActiveDocument.Selection
+      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
+    
+    End If
+  Next P
  
-
  txtLie.text = 5
  txtHang.text = Int(iPages / CInt(txtLie.text) + 0.9)
  txtLie.text = Int(iPages / CInt(txtHang.text) + 0.9)
@@ -139,39 +64,99 @@ ActiveDocument.Unit = cdrMillimeter '本文档单位为mm
  txtYouyi.text = iYouyi
  txtXiayi.text = iXiayi
  
-  LogoFile = Path & "GMS\262235.xyz\LOGO.jpg"
+  LogoFile = path & "GMS\LYVBA\LOGO.jpg"
   If API.ExistsFile_UseFso(LogoFile) Then
-    LogoPic.Picture = LoadPicture(LogoFile)   '换LOGO图
+    LogoPic.Picture = LoadPicture(LogoFile)   '// 换LOGO图
   End If
+
+  LNG_CODE = API.GetLngCode
+  Init_Translations Me, LNG_CODE
+  Me.Caption = i18n("Merge Multiple Pages Into One", LNG_CODE)
+  Me.Matrix.Caption = i18n("Matrix", LNG_CODE)
+  Me.OffsetSelection.Caption = i18n("Offset Selection", LNG_CODE)
+ 
+  txtInfo.text = i18n("Total Pages:", LNG_CODE) & iPages & "  " & i18n("Home Page Shape Size(mm):", LNG_CODE) & s.SizeWidth & "x" & s.SizeHeight
+End Sub
+
+'**** 主程序  执行
+Private Sub cmdRun_Click()
+  API.BeginOpt
+  
+  Dim x_M, y_M
+  ActiveDocument.EditAcrossLayers = False    '// 跨图层编辑禁止
+  
+  For Each P In ActiveDocument.Pages
+    P.Activate                              '// 激活每页
+    P.Shapes.all.CreateSelection            '// 每页全选
+    Set s(P.index) = ActiveSelection.Group  '// 存放每页的群组
+  Next P
+  
+  ActiveDocument.EditAcrossLayers = True     '// 跨图层编辑开启
+  
+  x_M = y_M = 0
+  
+  For Each P In ActiveDocument.Pages
+    P.Activate
+      
+    s(P.index).MoveToLayer ActivePage.DesktopLayer         '// 每页对象移动到桌面层
+    s(P.index).Move (iYouyi * x_M), -(300 + iXiayi * y_M)  '// 排列对象  右偏移，下偏移
+    
+    y_M = y_M + 1
+    
+    If y_M = iLie Then
+      x_M = x_M + 1
+      y_M = 0
+    End If
   
- txtInfo.text = "本文档共 " & iPages & " 页，首页物件尺寸(mm):" & s.SizeWidth & "×" & s.SizeHeight
+  Next P
   
+  Unload Me
+  API.EndOpt
 End Sub
 
+'**** 主程序 副本 横排序
+Private Sub cmdRunX_Click()
+  API.BeginOpt
 
-
-'帮助
-
-Private Sub cmdHelp_Click()
-
-WebHelp
-
-txtInfo.text = "点击访问 https://262235.xyz 详细帮助,寻找更多的视频教程！"
-txtInfo.ForeColor = &HFF0000
-cmdHelp.Caption = "在线帮助"
-cmdHelp.ForeColor = &HFF0000
-
-
+  Dim x_M, y_M
+  ActiveDocument.Unit = cdrMillimeter
+  ActiveDocument.EditAcrossLayers = False
+  
+  For Each P In ActiveDocument.Pages
+    P.Activate
+    P.Shapes.all.CreateSelection
+    Set s(P.index) = ActiveSelection.Group
+  Next P
+  
+  ActiveDocument.EditAcrossLayers = True
+  
+  x_M = y_M = 0
+  
+  For Each P In ActiveDocument.Pages
+    P.Activate
+    
+    s(P.index).MoveToLayer ActivePage.DesktopLayer
+    s(P.index).Move (iYouyi * y_M), -(600 + iXiayi * x_M)
+    
+    y_M = y_M + 1
+    
+    If y_M = iHang Then
+      x_M = x_M + 1
+      y_M = 0
+    End If
+  
+  Next P
+  
+  Unload Me
+  API.EndOpt
 End Sub
 
-
-'关闭
+'// 关闭
 Private Sub cmdClose_Click()
-Unload Me
+  Unload Me
 End Sub
 
-
-'VB限制文本框只能输入数字和小数点
+'// VB限制文本框只能输入数字和小数点
 Private Sub txtHang_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
 Dim Numbers As String
 Numbers = "1234567890"
@@ -214,10 +199,8 @@ Private Sub txtHang_Change()
  
  txtHang.text = iHang
  txtLie.text = Int(iPages / iHang + 0.9)
- 
   
   iLie = CInt(txtLie.text)
-    
 End Sub
 
 Private Sub HangSpin_Change()
@@ -259,13 +242,3 @@ Private Sub txtYouyi_Change()
     End If
 End Sub
 
-Function WebHelp()
- Dim h As Long, r As Long
- 
- If cmdHelp.Caption = "在线帮助" Then
- h = FindWindow(vbNullString, "CorelDRAW 合并多页为一页 蘭雅sRGB 2010-2022")
- r = ShellExecute(h, "", "https://262235.xyz/index.php/tag/vba/", "", "", 1)
- End If
-End Function
-
-

UI/frmSelectSame.frm

@@ -1,3 +1,20 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmSelectSame 
+   Caption         =   "Similar Selection Plus"
+   ClientHeight    =   5745
+   ClientLeft      =   495
+   ClientTop       =   5895
+   ClientWidth     =   3255
+   OleObjectBlob   =   "frmSelectSame.frx":0000
+   ShowModal       =   0   'False
+End
+Attribute VB_Name = "frmSelectSame"
+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
 

donate.md

@@ -25,10 +25,33 @@
 深蓝*浅蓝    壹方-渐变牙刷    zdj168    99彩印    JZ捷众广告    醉后的最后    骑着"蜗牛"撵娘们    
 极速龙广告装饰图文快印②    a-嘉盟    幼儿园最亮的仔    舞    方华广告    肥崽很忙    
 Thanh Van    友佳友汇    创忆电脑    李凯    晋畅迷你字    cdr_插件 鼠标哥    w啊啊    上善若水    
-肇庆博洋文化传媒    hi    夏夜里的荷花与星星    无风
+肇庆博洋文化传媒    hi    夏夜里的荷花与星星    无风   风雅广告
 ```
 ### 会员群福利: 
 ```
 1. 本工具免费开源，捐赠会员有得到最新内测版软件，和有限技术支持
 2. 捐赠网友将送商业版注册激活码一份
 ```
+
+## CorelDRAW Tools - Lanya Corelvba Plug-In For Coreldraw X4-2023
+
+## https://youtu.be/WL0EcMo09A0
+
+## https://www.bilibili.com/video/BV1PE42157uM
+
+
+I am Lanya, an open-source software author, and I have been working in graphic design for 23 years.
+
+My hobbies include writing and sharing code, sharing learning experiences, driving manual transmission vehicles, and sharing driving experiences.
+
+As we approach the Labor Day holiday in 2024, I am honored to introduce a piece of open-source software that I have developed: Lanya CorelDRAW Plugin International Labor Day Edition. This plugin combines my years of experience in graphic design and the guidance of many industry experts in the community. It represents a significant amount of wisdom and effort, taking two years to develop. I would also like to express my gratitude to the many generous donors who have contributed to the development and continuous improvement of open-source software projects, helping to maintain the freedom and openness of the plugin.
+
+Now, let me introduce the installation and basic usage of this permanently free, open-source software. As shown in the video, you simply need to click on "Lanya_CorelVBA.exe" to install it in the GMS directory of CorelDRAW. Then, open the script management panel, locate "Start" under the LYVBA project, and you will be able to access the main toolbar of the plugin. You can also set "Start" as an icon and place it on the toolbar of the CDR software. Additionally, you can directly double-click on other modules under the LYVBA project to launch separate tools. For example, double-clicking on "Start_Dimension" will directly open the enhanced version of batch dimension annotation.
+
+The Lanya CorelVBA plugin currently supports both Chinese and English languages, and you can click on the colorful multilingual icon to switch between them. This introduction video demonstrates the installation and usage testing on a Windows 11 English system.
+
+This open-source software project is available on GitHub and incorporates many innovations while maintaining simplicity and conciseness compared to similar software. It is suitable for hobbyist programmers who want to learn and improve their skills.
+
+Finally, I would like to express my gratitude for your support as it will contribute to the future development of "Lanya CorelVBA Tool." Thank you once again for your support.
+
+Lanya (hongwenjun)

module/ALGO.bas

@@ -1,3 +1,4 @@
+Attribute VB_Name = "ALGO"
 '// Algorithm 模块
 #If VBA7 Then
 '// For CorelDRAW X6-2023  62bit
@@ -6,6 +7,7 @@ Private Declare PtrSafe Function sort_byitem Lib "C:\TSP\lyvba.dll" (ByRef sr_Ar
                       ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
 #Else
 '// For CorelDRAW X4  32bit
+Declare Function i18n Lib "C:\TSP\lyvba32.dll" (ByVal str As String, ByVal code As Long) As String
 Declare Function sort_byitem Lib "C:\TSP\lyvba32.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
                       ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
 #End If
@@ -54,6 +56,10 @@ Public Function X4_Sort_ShapeRange(ByRef sr As ShapeRange, ByRef Sort_By As Sort
   Set X4_Sort_ShapeRange = ShapeRange_To_Sort_Array(sr, Sort_By)
 End Function
 
+Public Function sorted(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
+  Set sorted = ShapeRange_To_Sort_Array(sr, Sort_By)
+End Function
+
 '// 映射 ShapeRange 到 Array 然后调用 DLL库排序
 Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
   On Error GoTo ErrorHandler
@@ -82,10 +88,12 @@ Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By
   '// sr_Array首地址，size 长度， Sort_By 排序方式, 返回数组 ret_Array
   ret = sort_byitem(sr_Array(1), size, Sort_By, ret_Array(1))
   
+'  Debug.Print ret, size
   If ret = size Then
     Dim srcp As New ShapeRange, i As Integer
     For i = 1 To size
       srcp.Add sr(ret_Array(i))
+'     Debug.Print i
     Next i
     
     Set ShapeRange_To_Sort_Array = srcp

module/API.bas

@@ -55,12 +55,19 @@ Public Function GetSet(s As String)
   
 End Function
 
+Public Function GetLngCode() As Long
+  GetLngCode = Val(GetSetting("LYVBA", "Settings", "I18N_LNG", "1033"))
+End Function
+
+
 Public Function Create_Tolerance() As Double
   Dim text As String
   If GlobalUserData.Exists("Tolerance", 1) Then
     text = GlobalUserData("Tolerance", 1)
   End If
-  text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
+  
+  LNG_CODE = API.GetLngCode
+  text = InputBox(i18n("Please enter a tolerance value 0.1 --> 9.9", LNG_CODE), i18n("Tolerance(mm)", LNG_CODE), text)
   If text = "" Then Exit Function
   GlobalUserData("Tolerance", 1) = text
   Create_Tolerance = Val(text)
@@ -75,7 +82,8 @@ Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As D
       Exit Function
     End If
   End If
-  text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
+  LNG_CODE = API.GetLngCode
+  text = InputBox(i18n("Please enter a gap width value -99 --> 99", LNG_CODE), i18n("Set Space Width(mm)", LNG_CODE), text)
   If text = "" Then Exit Function
   GlobalUserData("SpaceWidth", 1) = text
   Set_Space_Width = Val(text)
@@ -201,14 +209,14 @@ Public Function pFootInXY(P, a, b)
     If a(1) = b(1) Then
         pFootInXY = Array(P(0), a(1), 0#): Exit Function
     End If
-    Dim aa, bb, c, d, x, Y
+    Dim aa, bb, c, d, X, Y
     aa = (a(1) - b(1)) / (a(0) - b(0))
     bb = a(1) - aa * a(0)
     c = -(a(0) - b(0)) / (a(1) - b(1))
     d = P(1) - c * P(0)
-    x = (d - bb) / (aa - c)
-    Y = aa * x + bb
-    pFootInXY = Array(x, Y, 0#)
+    X = (d - bb) / (aa - c)
+    Y = aa * X + bb
+    pFootInXY = Array(X, Y, 0#)
 End Function
 
 

module/Arrange.bas

@@ -1,4 +1,5 @@
 Attribute VB_Name = "Arrange"
+'// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 
 '// Attribute VB_Name = "物件排列拼版"   Arrange  2023.12.20
@@ -31,11 +32,11 @@ Public Function Arrange()
   arr = Split(str)
 
   Dim s1 As Shape
-  Dim x As Double, Y As Double
+  Dim X As Double, Y As Double
   
   If 0 = ActiveSelectionRange.Count Then
-    x = Val(arr(0)):    Y = Val(arr(1))
-    row = Int(ActiveDocument.Pages.First.SizeWidth / x)
+    X = Val(arr(0)):    Y = Val(arr(1))
+    row = Int(ActiveDocument.Pages.First.SizeWidth / X)
     List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
 
     If UBound(arr) > 2 Then
@@ -48,7 +49,7 @@ Public Function Arrange()
     End If
      
     '// 建立矩形 Width  x Height 单位 mm
-    Set s1 = ActiveLayer.CreateRectangle(0, 0, x, Y)
+    Set s1 = ActiveLayer.CreateRectangle(0, 0, X, Y)
     
     '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
     s1.Fill.ApplyNoFill
@@ -58,12 +59,12 @@ Public Function Arrange()
   '// 如果当前选择物件，按当前物件拼版
   ElseIf 0 < ActiveSelectionRange.Count Then
     Set s1 = ActiveSelection
-    x = s1.SizeWidth:    Y = s1.SizeHeight
-    row = Int(ActiveDocument.Pages.First.SizeWidth / x)
+    X = s1.SizeWidth:    Y = s1.SizeHeight
+    row = Int(ActiveDocument.Pages.First.SizeWidth / X)
     List = Int(ActiveDocument.Pages.First.SizeHeight / Y)
   End If
   
-  sw = x:  sh = Y
+  sw = X:  sh = Y
 
   '// StepAndRepeat 方法在范围内创建多个形状副本
   Dim dup1 As ShapeRange, dup2 As ShapeRange
@@ -85,3 +86,4 @@ End Function
 '  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
 
 
+

module/AutoColorMark.bas

@@ -19,7 +19,7 @@ Function Auto_ColorMark()
   px = ActiveDocument.ActivePage.CenterX
   py = ActiveDocument.ActivePage.CenterY
   '// 导入色阶条中线对准线标记文件 ColorMark.cdr 解散群组
-  doc.ActiveLayer.Import Path & "GMS\ColorMark.cdr"
+  doc.ActiveLayer.Import path & "GMS\ColorMark.cdr"
   ActiveDocument.ReferencePoint = cdrBottomMiddle
   ' ActiveDocument.Selection.SetPosition px, -100
   ActiveDocument.Selection.Ungroup
@@ -169,7 +169,7 @@ End Function
 Private Function put_page_size()
   ' 添加文字 页面大小和文件名
   Dim st As Shape
-  size = Trim(Str(Int(ActivePage.SizeWidth))) + "x" + Trim(Str(Int(ActivePage.SizeHeight))) + "mm"
+  size = Trim(str(Int(ActivePage.SizeWidth))) + "x" + Trim(str(Int(ActivePage.SizeHeight))) + "mm"
   size = size & " " & ActiveDocument.FileName & " " & Date '
   Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 7)
 End Function
@@ -236,7 +236,7 @@ End Function
 Private Function put_page_size()
   ' 添加文字 页面大小
   Dim st As Shape
-  size = Trim(Str(Int(ActivePage.SizeWidth))) + "x" + Trim(Str(Int(ActivePage.SizeHeight))) + "mm"
+  size = Trim(str(Int(ActivePage.SizeWidth))) + "x" + Trim(str(Int(ActivePage.SizeHeight))) + "mm"
   Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 7)
   st.AlignToPage cdrAlignRight + cdrAlignTop
   st.Move -3, -0.6
@@ -260,7 +260,7 @@ Function Auto_ColorMark_K()
   px = ActiveDocument.ActivePage.CenterX
   py = ActiveDocument.ActivePage.CenterY
   '// 导入色阶条中线对准线标记文件 ColorMark.cdr 解散群组
-  doc.ActiveLayer.Import Path & "GMS\ColorMark.cdr"
+  doc.ActiveLayer.Import path & "GMS\ColorMark.cdr"
   ActiveDocument.ReferencePoint = cdrBottomMiddle
   ' ActiveDocument.Selection.SetPosition px, -100
   ActiveDocument.Selection.Ungroup

module/CorelVBA.bas

@@ -2,7 +2,17 @@ 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
+
+Public Sub Init_StartButton()
+  SaveSetting "LYVBA", "Settings", "StartButton", "0"
+  MsgBox "Please Restart CorelDRAW!"
 End Sub
 

module/HDPI.bas

@@ -36,5 +36,5 @@ Public Function GetHDPIPercentage() As Integer
 End Function
 
 Sub MSG_HDPIPercentage()
-  MsgBox GetHDPIPercentage
+  MsgBox "HDPI Percentage:" & GetHDPIPercentage
 End Sub

module/HotKeys.bas

@@ -0,0 +1,32 @@
+Attribute VB_Name = "HotKeys"
+Sub Start_SelectSame()
+  '// 选择相同工具增强版
+  frmSelectSame.Show 0
+End Sub
+
+Sub Start_CQL_FIND()
+  '// 简单查找
+  CQL_FIND_UI.Show 0
+End Sub
+
+Sub Start_Batch_Replace()
+  '// 批量替换
+  Replace_UI.Show 0
+End Sub
+
+Sub Start_Arrange()
+  '// 开始拼版
+   ArrangeForm.Show 0
+End Sub
+
+Sub Start_CutLines()
+  CutLines.Draw_Lines  '// 调用角线
+End Sub
+
+Sub AIClipboard_CopyAIFormat()
+   value = GMSManager.RunMacro("AIClipboard", "CopyPaste.CopyAIFormat")
+End Sub
+
+Sub AIClipboard_PasteAIFormat()
+   value = GMSManager.RunMacro("AIClipboard", "CopyPaste.PasteAIFormat")
+End Sub

module/SmartGroup.bas

@@ -1,3 +1,4 @@
+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
 
@@ -10,16 +11,16 @@ Public Function Smart_Group(Optional ByVal tr As Double = 0) As ShapeRange
 
   Dim OrigSelection As ShapeRange, sr As New ShapeRange
   Dim s1 As Shape, sh As Shape, s As Shape
-  Dim x As Double, Y As Double, w As Double, h As Double
+  Dim X As Double, Y As Double, w As Double, h As Double
   Dim eff1 As Effect
   
   Set OrigSelection = ActiveSelectionRange
 
   '// 遍历物件画矩形
   For Each sh In OrigSelection
-    sh.GetBoundingBox x, Y, w, h
+    sh.GetBoundingBox X, Y, w, h
     If w * h > 4 Then
-      Set s = ActiveLayer.CreateRectangle2(x - tr, Y - tr, w + 2 * tr, h + 2 * tr)
+      Set s = ActiveLayer.CreateRectangle2(X - tr, Y - tr, w + 2 * tr, h + 2 * tr)
       sr.Add s
 
     '// 轴线 创建轮廓处理

module/StoreSelect.bas

@@ -1,19 +1,17 @@
+Attribute VB_Name = "StoreSelect"
 Private sr_mem(3) As New ShapeRange
 Public StoreCount As String
 
 Public Function Store_Instruction(id As Integer, INST As String) As String
   On Error GoTo ErrorHandler
   API.BeginOpt "Undo MRC"
-  '// 选择指令执行
+  '// Ñ¡ÔñÖ¸ÁîÖ´ÐÐ
   Case_Select_Range id, INST
   
   StoreCount = "Store Count: A->" & sr_mem(1).Count & "  B->" & sr_mem(2).Count & "  C->" & sr_mem(3).Count
-  API.EndOpt
-  
-Exit Function
 
 ErrorHandler:
-  Application.Optimization = False
+  API.EndOpt
 End Function
 
 Private Function Case_Select_Range(id As Integer, INST As String)
@@ -34,9 +32,7 @@ Private Function Case_Select_Range(id As Integer, INST As String)
     End If
 
   End Select
-  
-Exit Function
 
 ErrorHandler:
-  Application.Optimization = False
+  API.EndOpt
 End Function

module/ThisMacroStorage.cls

@@ -12,42 +12,41 @@ Private Sub GlobalMacroStorage_start()
   Dim creatTool As Boolean: creatTool = True
   StartButton = Val(GetSetting("LYVBA", "Settings", "StartButton", "0"))
   If StartButton = 1 Then creatTool = False
-  
+
   If creatTool Then
     SaveSetting "LYVBA", "Settings", "StartButton", "1"
     AddPluginCommand "LYVBA.CorelVBA.Start", "CorelVBA.Start", "CorelVBA.Start"
     AddPluginCommand "LYVBA.CorelVBA.Start_Dimension", "CorelVBA.Start_Dimension", "CorelVBA.Start_Dimension"
     AddPluginCommand "LinesTool.lines.start", "lines.start", "lines.start"
     AddPluginCommand "ZeroBase.Hello_VBA.run", "Hello_VBA.run", "Hello_VBA.run"
-    
+
     For Each Item In CommandBars
       If Item.name = "CorelVBA" Then
           creatTool = False
       End If
     Next
     If creatTool Then CommandBars.Add "CorelVBA"
-    
+
     With CommandBars.Item("CorelVBA")
       .Visible = True
-      
       Set ctl = .Controls.AddCustomButton(cdrCmdCategoryMacros, "LYVBA.CorelVBA.Start")
-      ver = Val(Version)
-      If ver < 17 Then
-        ctl.SetCustomIcon "C:\TSP\LYVBA.ico"
-      Else
-        ctl.SetIcon2 ("guid://a8e62a7a-d5d2-4a05-8d5d-e07d6bd21993") '// 输出中心图标
-      End If
-
+      ' ctl.SetIcon2 ("guid://a8e62a7a-d5d2-4a05-8d5d-e07d6bd21993")
       Set ctl2 = .Controls.AddCustomButton(cdrCmdCategoryMacros, "LYVBA.CorelVBA.Start_Dimension")
-      ctl2.SetIcon2 ("guid://b4b9632a-248b-4d80-a62d-88804e50a955") '// 标尺工具图标
-      
       Set ctl3 = .Controls.AddCustomButton(cdrCmdCategoryMacros, "LinesTool.lines.start")
-      ctl3.SetIcon2 ("guid://d2fdc0d9-09f8-4948-944c-4297395c05b7")
-      
       Set ctl4 = .Controls.AddCustomButton(cdrCmdCategoryMacros, "ZeroBase.Hello_VBA.run")
-      ctl4.SetIcon2 ("guid://1a0b1202-d0ef-4fe7-8a95-ac7617b30703")
-      
     End With
   End If
+  
+  refresh_Icon
 ErrorHandler:
 End Sub
+
+Private Function refresh_Icon()
+  With CommandBars.Item("CorelVBA")
+    .Controls.Item(1).SetIcon2 ("guid://a8e62a7a-d5d2-4a05-8d5d-e07d6bd21993")
+    .Controls.Item(2).SetIcon2 ("guid://b4b9632a-248b-4d80-a62d-88804e50a955")
+    .Controls.Item(3).SetIcon2 ("guid://d2fdc0d9-09f8-4948-944c-4297395c05b7")
+    .Controls.Item(4).SetIcon2 ("guid://1a0b1202-d0ef-4fe7-8a95-ac7617b30703")
+  End With
+End Function
+

module/Tools.bas

@@ -174,7 +174,7 @@ End Function
 '''///  使用Python脚本 整理尺寸 提取条码数字 建立二维码 位图转文本 ///'''
 Public Function Python_Organize_Size()
   On Error GoTo ErrorHandler
-  mypy = Path & "GMS\LYVBA\Organize_Size.py"
+  mypy = path & "GMS\LYVBA\Organize_Size.py"
   cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
   Shell cmd_line
 ErrorHandler:
@@ -182,7 +182,7 @@ End Function
 
 Public Function Python_Get_Barcode_Number()
   On Error GoTo ErrorHandler
-  mypy = Path & "GMS\LYVBA\Get_Barcode_Number.py"
+  mypy = path & "GMS\LYVBA\Get_Barcode_Number.py"
   cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
   Shell cmd_line
 ErrorHandler:
@@ -190,7 +190,7 @@ End Function
 
 Public Function Python_BITMAP()
   On Error GoTo ErrorHandler
-  mypy = Path & "GMS\LYVBA\BITMAP.py"
+  mypy = path & "GMS\LYVBA\BITMAP.py"
   cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
   Shell cmd_line
 ErrorHandler:
@@ -206,7 +206,7 @@ End Function
 
 Public Function Python_Make_QRCode()
   On Error GoTo ErrorHandler
-  mypy = Path & "GMS\LYVBA\Make_QRCode.py"
+  mypy = path & "GMS\LYVBA\Make_QRCode.py"
   cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
   Shell cmd_line
 ErrorHandler:
@@ -715,6 +715,7 @@ Public Function Batch_Align_Page_Center()
   On Error GoTo ErrorHandler
   API.BeginOpt
   
+  Dim sr As ShapeRange
   Set sr = ActiveSelectionRange
   total = sr.Count
 
@@ -722,29 +723,26 @@ Public Function Batch_Align_Page_Center()
   Set doc = ActiveDocument
   doc.AddPages (total - 1)
 
-#If VBA7 Then
-  sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
-#Else
-' X4 不支持 ShapeRange.sort
-  Set sr = X4_Sort_ShapeRange(ssr, topWt_left).ReverseRange
-#End If
+  Set sr = sorted(sr, topWt_left)
 
   Dim sh As Shape
-  '// 遍历批量物件，放置物件到页面
+  '// 遍历批量物件，放置物件到页面  InsertPagesEx   ActivePage
   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)
  
-    sh.MoveToLayer ActivePage.ActiveLayer
    '// 物件居中页面
-#If VBA7 Then
-    ActiveDocument.ClearSelection
-    sh.AddToSelection
-    ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
-#Else
-    sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
-#End If
+    #If VBA7 Then
+      ActiveDocument.ClearSelection
+      sh.AddToSelection
+      sh.MoveToLayer ActivePage.ActiveLayer
+      
+      ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+    #Else
+      sh.MoveToLayer doc.Pages(i).ActiveLayer
+      sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+    #End If
 
   Next i
 ErrorHandler:

python/convert.py

@@ -36,5 +36,5 @@ def ReadDirectoryFile(rootdir):
                            os.path.join(parent, filename))
 
 if __name__ == "__main__":
-    src_path = "R:/zip"
+    src_path = "C:/Soft/Git/srgb/corelvba/module"
     ReadDirectoryFile(src_path)

python/convert_ui.py

@@ -0,0 +1,40 @@
+import os
+import chardet
+import codecs
+
+
+def WriteFile(filePath, u, encoding="utf-8"):
+    with codecs.open(filePath, "w", encoding) as f:
+        f.write(u)
+
+
+def GBK_2_UTF8(src, dst):
+    #     检测编码，coding可能检测不到编码，有异常
+    f = open(src, "rb")
+    coding = chardet.detect(f.read())["encoding"]
+    f.close()
+    if coding != "utf-8":
+        with codecs.open(src, "r", coding) as f:
+            try:
+                WriteFile(dst, f.read(), encoding="utf-8")
+                try:
+                    print(src + "  " + coding + " to utf-8  converted!")
+                except Exception:
+                    print("print error")
+            except Exception:
+                print(src +"  "+ coding+ "  read error")
+
+# 把目录中的*.bas编码由gbk转换为utf-8
+def ReadDirectoryFile(rootdir):
+    for parent, dirnames, filenames in os.walk(rootdir):
+        for dirname in dirnames:
+          	#递归函数，遍历所有子文件夹
+            ReadDirectoryFile(dirname)
+        for filename in filenames:
+            if filename.endswith(".frm"):
+                GBK_2_UTF8(os.path.join(parent, filename),
+                           os.path.join(parent, filename))
+
+if __name__ == "__main__":
+    src_path = "C:/Soft/Git/srgb/corelvba/UI"
+    ReadDirectoryFile(src_path)

zerobase/API.bas

@@ -1,30 +1,262 @@
 Attribute VB_Name = "API"
-Public Function BeginOpt(Name As String)
+'// 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
-  ActiveDocument.BeginCommandGroup Name
-  ActiveDocument.SaveSettings
-  ActiveDocument.unit = cdrMillimeter
+  ActiveDocument.BeginCommandGroup name
+' ActiveDocument.SaveSettings
+  ActiveDocument.Unit = cdrMillimeter
   Optimization = True
 ' ActiveDocument.PreserveSelection = False
 End Function
 
 Public Function EndOpt()
 ' ActiveDocument.PreserveSelection = True
-  ActiveDocument.RestoreSettings
+' ActiveDocument.RestoreSettings
   EventsEnabled = True
   Optimization = False
   EventsEnabled = True
+  ActiveDocument.ReferencePoint = cdrBottomLeft
   Application.Refresh
   ActiveDocument.EndCommandGroup
 End Function
 
+Public Function Speak_Msg(message As String)
+  Speak_Help = Val(GetSetting("LYVBA", "Settings", "SpeakHelp", "0"))     '// 关停语音功能
+  
+  If Val(Speak_Help) = 1 Then
+    Dim sapi
+    Set sapi = CreateObject("sapi.spvoice")
+    sapi.Speak message
+  Else
+    ' 不说话
+  End If
+
+End Function
+
+Public Function GetSet(s As String)
+  Bleed = Val(GetSetting("LYVBA", "Settings", "Bleed", "2.0"))
+  Line_len = Val(GetSetting("LYVBA", "Settings", "Line_len", "3.0"))
+  Outline_Width = Val(GetSetting("LYVBA", "Settings", "Outline_Width", "0.2"))
+' Debug.Print Bleed, Line_len, Outline_Width
+
+  If s = "Bleed" Then
+    GetSet = Bleed
+  ElseIf s = "Line_len" Then
+    GetSet = Line_len
+  ElseIf s = "Outline_Width" Then
+    GetSet = Outline_Width
+  End If
+  
+End Function
+
 Public Function Create_Tolerance() As Double
   Dim text As String
   If GlobalUserData.Exists("Tolerance", 1) Then
     text = GlobalUserData("Tolerance", 1)
   End If
-  text = InputBox("璇疯緭鍏ュ�宸�€� 0.1 --> 99.9", "瀹瑰樊鍊�(mm)", text)
+  text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
   If text = "" Then Exit Function
   GlobalUserData("Tolerance", 1) = text
   Create_Tolerance = Val(text)
 End Function
+
+Public Function Set_Space_Width(Optional ByVal OnlyRead As Boolean = False) As Double
+  Dim text As String
+  If GlobalUserData.Exists("SpaceWidth", 1) Then
+    text = GlobalUserData("SpaceWidth", 1)
+    If OnlyRead Then
+      Set_Space_Width = Val(text)
+      Exit Function
+    End If
+  End If
+  text = InputBox("请输入间隔宽度值 -99 --> 99", "设置间隔宽度(mm)", text)
+  If text = "" Then Exit Function
+  GlobalUserData("SpaceWidth", 1) = text
+  Set_Space_Width = Val(text)
+End Function
+
+'// 获得剪贴板文本字符
+Public Function GetClipBoardString() As String
+  On Error Resume Next
+  Dim MyData As New DataObject
+  GetClipBoardString = ""
+  MyData.GetFromClipboard
+  GetClipBoardString = MyData.GetText
+  Set MyData = Nothing
+End Function
+
+'// 文本字符复制到剪贴板
+Public Function WriteClipBoard(ByVal s As String)
+  On Error Resume Next
+
+' VBA_WIN10(vba7) 使用PutInClipboard乱码解决办法
+#If VBA7 Then
+  With CreateObject("Forms.TextBox.1")
+    .MultiLine = True
+    .text = s
+    .SelStart = 0
+    .SelLength = .TextLength
+    .Copy
+  End With
+#Else
+  Dim MyData As New DataObject
+  MyData.SetText s
+  MyData.PutInClipboard
+#End If
+End Function
+
+'// 换行转空格 多个空格换成一个空格
+Public Function Newline_to_Space(ByVal str As String) As String
+  str = VBA.Replace(str, Chr(13), " ")
+  str = VBA.Replace(str, Chr(9), " ")
+  Do While InStr(str, "  ")
+      str = VBA.Replace(str, "  ", " ")
+  Loop
+  Newline_to_Space = str
+End Function
+
+'// 获得数组元素个数
+Public Function arrlen(src As Variant) As Integer
+  On Error Resume Next '空意味着 0 长度
+  arrlen = (UBound(src) - LBound(src))
+End Function
+
+'// 对数组进行排序[单维]
+Public Function ArraySort(src As Variant) As Variant
+  Dim out As Long, i As Long, tmp As Variant
+  For out = LBound(src) To UBound(src) - 1
+    For i = out + 1 To UBound(src)
+      If src(out) > src(i) Then
+        tmp = src(i): src(i) = src(out): src(out) = tmp
+      End If
+    Next i
+  Next out
+  
+  ArraySort = src
+End Function
+
+'//  把一个数组倒序
+Public Function ArrayReverse(arr)
+    Dim i As Integer, n As Integer
+    n = UBound(arr)
+    Dim P(): ReDim P(n)
+    For i = 0 To n
+        P(i) = arr(n - i)
+    Next
+    ArrayReverse = P
+End Function
+
+'// 测试数组排序
+Private Function test_ArraySort()
+  Dim arr As Variant, i As Integer
+  arr = Array(5, 4, 3, 2, 1, 9, 999, 33)
+  For i = 0 To arrlen(arr) - 1
+    Debug.Print arr(i);
+  Next i
+  Debug.Print arrlen(arr)
+  ArraySort arr
+  For i = 0 To arrlen(arr) - 1
+    Debug.Print arr(i);
+  Next i
+End Function
+
+'// 两点连线的角度：返回角度(相对于X轴的角度)
+'// p为末点，O为始点
+Public Function alfaPP(P, o)
+    Dim pi As Double: pi = 4 * Atn(1)
+    Dim beta As Double
+    If P(0) = o(0) And P(1) = o(1) Then '二点重合
+        alfaPP = 0
+        Exit Function
+    ElseIf P(0) = o(0) And P(1) > o(1) Then
+        beta = pi / 2
+    ElseIf P(0) = o(0) And P(1) < o(1) Then
+        beta = -pi / 2
+    ElseIf P(1) = o(1) And P(0) < o(0) Then
+        beta = pi
+    ElseIf P(1) = o(1) And P(0) > o(0) Then
+        beta = 0
+    Else
+        beta = Atn((P(1) - o(1)) / VBA.Abs(P(0) - o(0)))
+        If P(1) > o(1) And P(0) < o(0) Then
+            beta = pi - beta
+        ElseIf P(1) < o(1) And P(0) < o(0) Then
+            beta = -(pi + beta)
+        End If
+    End If
+    alfaPP = beta * 180 / pi
+End Function
+
+'// 求过P点到线段AB上的垂足点(XY平面内的二维计算)
+Public Function pFootInXY(P, a, b)
+    If a(0) = b(0) Then
+        pFootInXY = Array(a(0), P(1), 0#): Exit Function
+    End If
+    If a(1) = b(1) Then
+        pFootInXY = Array(P(0), a(1), 0#): Exit Function
+    End If
+    Dim aa, bb, c, d, x, Y
+    aa = (a(1) - b(1)) / (a(0) - b(0))
+    bb = a(1) - aa * a(0)
+    c = -(a(0) - b(0)) / (a(1) - b(1))
+    d = P(1) - c * P(0)
+    x = (d - bb) / (aa - c)
+    Y = aa * x + bb
+    pFootInXY = Array(x, Y, 0#)
+End Function
+
+
+Public Function FindAllShapes() As ShapeRange
+  Dim s As Shape
+  Dim srPowerClipped As New ShapeRange
+  Dim sr As ShapeRange, srAll As New ShapeRange
+  
+  If ActiveSelection.Shapes.Count > 0 Then
+    Set sr = ActiveSelection.Shapes.FindShapes()
+  Else
+    Set sr = ActivePage.Shapes.FindShapes()
+  End If
+  
+  Do
+    For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
+        srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
+    Next s
+    srAll.AddRange sr
+    sr.RemoveAll
+    sr.AddRange srPowerClipped
+    srPowerClipped.RemoveAll
+  Loop Until sr.Count = 0
+  
+  Set FindAllShapes = srAll
+End Function
+
+' ************* 函数模块 ************* '
+Public Function ExistsFile_UseFso(ByVal strPath As String) As Boolean
+     Dim fso
+     Set fso = CreateObject("Scripting.FileSystemObject")
+     ExistsFile_UseFso = fso.FileExists(strPath)
+     Set fso = Nothing
+End Function
+
+Public Function test_sapi()
+  Dim message, sapi
+  MsgBox ("Please use the headset and listen to what I have to say...")
+  message = "This is a simple voice test on your Microsoft Windows."
+  Set sapi = CreateObject("sapi.spvoice")
+  sapi.Speak message
+End Function
+
+
+' Public Function WebHelp(url As String)
+'  Dim h As Longer, r As Long
+'  h = FindWindow(vbNullString, "Toolbar")
+'  r = ShellExecute(h, "", url, "", "", 1)
+' End Function
+
+

zerobase/ArrangeForm.frm

@@ -1,13 +1,13 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ArrangeForm 
-   Caption         =   "铇�泤sRGB 鎵嬪姩鎷肩増 鈹� 鍢夌洘璧炲姪"
+   Caption         =   "蘭雅sRGB 手动拼版 │ 嘉盟赞助"
    ClientHeight    =   2475
    ClientLeft      =   45
    ClientTop       =   330
    ClientWidth     =   4650
    OleObjectBlob   =   "ArrangeForm.frx":0000
    ShowModal       =   0   'False
-   StartUpPosition =   2  '灞忓箷涓�績
+   StartUpPosition =   2  'CenterScreen
    WhatsThisButton =   -1  'True
    WhatsThisHelp   =   -1  'True
 End
@@ -39,15 +39,15 @@ Private Sub CommandButton1_Click()
     Exit Sub
   End If
   
-  '// 浠ｇ爜杩愯�鏃跺叧闂�獥鍙ｅ埛鏂�
+  '// 代码运行时关闭窗口刷新
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
-  '// 鎷肩増鐭╅樀
+  '// 拼版矩阵
   arrange_Clone matrix, s
 
   ActiveDocument.EndCommandGroup
   Unload Me
   
-  '// 浠ｇ爜鎿嶄綔缁撴潫鎭㈠�绐楀彛鍒锋柊
+  '// 代码操作结束恢复窗口刷新
   ActiveDocument.EndCommandGroup
   Application.Optimization = False
   ActiveWindow.Refresh:    Application.Refresh
@@ -57,31 +57,31 @@ ErrorHandler:
   On Error Resume Next
 End Sub
 
-'// 鎷肩増鐭╅樀  matrix = Array(ls,hs,lj,hj)
+'// 拼版矩阵  matrix = Array(ls,hs,lj,hj)
 Private Function arrange_Clone(matrix As Variant, s As ShapeRange)
   ls = matrix(0): hs = matrix(1)
   lj = matrix(2): hj = matrix(3)
-  x = s.SizeWidth: y = s.SizeHeight
+  x = s.SizeWidth: Y = s.SizeHeight
   Set s1 = s.Clone
-  '// StepAndRepeat 鏂规硶鍦ㄨ寖鍥村唴鍒涘缓澶氫釜褰㈢姸鍓�湰
+  '// StepAndRepeat 方法在范围内创建多个形状副本
   Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
-  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(y + hj))
+  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
   s1.Delete
 End Function
 
 Private Function arrange_Clone_one(matrix As Variant, s As ShapeRange)
   ls = matrix(0): hs = matrix(1)
   lj = matrix(2): hj = matrix(3)
-  x = s.SizeWidth: y = s.SizeHeight
+  x = s.SizeWidth: Y = s.SizeHeight
   Set s1 = s.Clone
-  '// StepAndRepeat 鏂规硶鍦ㄨ寖鍥村唴鍒涘缓澶氫釜褰㈢姸鍓�湰
+  '// StepAndRepeat 方法在范围内创建多个形状副本
   If ls > 1 Then
     Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
   Else
     Set dup1 = s1
   End If
   If hs > 1 Then
-    Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(y + hj))
+    Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
   End If
   s1.Delete
 End Function

zerobase/AutoCutLines.bas

@@ -9,55 +9,53 @@ Public Sub AutoCutLines()
   Nodes_TO_TSP
   START_Cut_Line_Algorithm 3#
   
-  '寤舵椂500姣��锛屽�鏋滅數鑴戝�蹇�紝鍙�互璋冩暣鍒�100ms
+  '延时500毫秒，如果电脑够快，可以调整到100ms
   Sleep 500
-  TSP_TO_DRAW_LINES
+ '// TSP_TO_DRAW_LINES
+  TSP_TO_DRAW_LINE
 End Sub
 
 Private Function Nodes_TO_TSP()
-    On Error GoTo ErrorHandler
-    ActiveDocument.BeginCommandGroup: Application.Optimization = True
-    ActiveDocument.Unit = cdrMillimeter
-
-    Set fs = CreateObject("Scripting.FileSystemObject")
-    Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
+  On Error GoTo ErrorHandler
+  API.BeginOpt "Nodes_TO_TSP"
+  
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
 
-    Dim s As Shape, ssr As ShapeRange
-    Set ssr = ActiveSelectionRange
+  Dim s As Shape, ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
 
-    Dim TSP As String
-    TSP = (ssr.Count * 4) & " " & 0 & vbNewLine
+  Dim TSP As String
+  TSP = (ssr.Count * 4) & " " & 0 & vbNewLine
 
-    For Each s In ssr
-        lx = s.LeftX:   rx = s.RightX
-        By = s.BottomY: ty = s.TopY
-        TSP = TSP & lx & " " & By & vbNewLine
-        TSP = TSP & lx & " " & ty & vbNewLine
-        TSP = TSP & rx & " " & By & vbNewLine
-        TSP = TSP & rx & " " & ty & vbNewLine
-    Next s
-    f.WriteLine TSP
-    f.Close
-    
-    '// 鍒锋柊涓€涓嬫枃浠舵祦锛屽欢鏃剁殑鏁堟灉
-    Set f = fs.OpenTextFile("C:\TSP\CDR_TO_TSP", 1, False)
-    Dim str
-    str = f.ReadAll()
-    f.Close
-    
-  ActiveDocument.EndCommandGroup: Application.Optimization = False
-  ActiveWindow.Refresh: Application.Refresh
+  For Each s In ssr
+      lx = s.LeftX:   rx = s.RightX
+      By = s.BottomY: ty = s.TopY
+      TSP = TSP & lx & " " & By & vbNewLine
+      TSP = TSP & lx & " " & ty & vbNewLine
+      TSP = TSP & rx & " " & By & vbNewLine
+      TSP = TSP & rx & " " & ty & vbNewLine
+  Next s
+  f.WriteLine TSP
+  f.Close
+  
+  '// 刷新一下文件流，延时的效果
+  Set f = fs.OpenTextFile("C:\TSP\CDR_TO_TSP", 1, False)
+  Dim str
+  str = f.ReadAll()
+  f.Close
+  
+  API.EndOpt
 Exit Function
 ErrorHandler:
     Application.Optimization = False
     On Error Resume Next
 End Function
 
-'//  TSP鍔熻兘鐢荤嚎-澶氱嚎娈�
+'//  TSP功能画线-多线段
 Private Function TSP_TO_DRAW_LINES()
   On Error GoTo ErrorHandler
-  ActiveDocument.BeginCommandGroup: Application.Optimization = True
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt "TSP_TO_DRAW_LINES"
   
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
@@ -76,43 +74,85 @@ Private Function TSP_TO_DRAW_LINES()
   arr = Split(str)
   For n = 2 To UBound(arr) - 1 Step 4
     x = Val(arr(n))
-    y = Val(arr(n + 1))
+    Y = Val(arr(n + 1))
     x1 = Val(arr(n + 2))
     y1 = Val(arr(n + 3))
 
-    Set line = ActiveLayer.CreateLineSegment(x, y, x1, y1)
+    Set line = ActiveLayer.CreateLineSegment(x, Y, x1, y1)
     set_line_color line
     
-    ' 璋冭瘯绾挎潯椤哄簭
-    puts x, y, (n + 2) / 4
+    ' 调试线条顺序
+    puts x, Y, (n + 2) / 4
     
   Next
   
   ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
-  ActiveSelection.group
+  ActiveSelection.Group
   ActiveSelection.Outline.SetProperties 0.2, Color:=CreateCMYKColor(0, 100, 100, 0)
   
-  ActiveDocument.EndCommandGroup: Application.Optimization = False
-  ActiveWindow.Refresh: Application.Refresh
+  API.EndOpt
 Exit Function
 ErrorHandler:
     Application.Optimization = False
     On Error Resume Next
 End Function
 
-'// 杩愯�瑁佸垏绾跨畻娉� Cut_Line_Algorithm.py
+'// 运行裁切线算法 Cut_Line_Algorithm.py
 Private Function START_Cut_Line_Algorithm(Optional ext As Double = 3)
     cmd_line = "python C:\TSP\Cut_Line_Algorithm.py" & " " & ext
     Shell cmd_line
 End Function
 
-'// 璁剧疆绾挎潯鏍囪�(棰滆壊)
+'// 设置线条标记(颜色)
 Private Function set_line_color(line As Shape)
   line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
 End Function
 
-Public Sub puts(x, y, n)
+Public Sub puts(x, Y, n)
   Dim st As String
   st = str(n)
-  Set s = ActiveLayer.CreateArtisticText(x, y, st)
+  Set s = ActiveLayer.CreateArtisticText(x, Y, st)
 End Sub
+
+
+'//  TSP功能画线-弓形线
+
+Public Function TSP_TO_DRAW_LINE()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
+  Dim str, arr, n
+  str = f.ReadAll()
+  
+  str = API.Newline_to_Space(str)
+  arr = Split(str)
+  total = Val(arr(0)) * 2
+  
+  ReDim ce(total) As CurveElement
+  Dim crv As Curve
+  
+  ce(0).ElementType = cdrElementStart
+  ce(0).PositionX = Val(arr(2)) ' - 3
+  ce(0).PositionY = Val(arr(3)) ' - 3
+  
+  Dim x As Double
+  Dim Y As Double
+  For n = 2 To UBound(arr) - 1 Step 2
+    x = Val(arr(n))
+    Y = Val(arr(n + 1))
+  
+    ce(n / 2).ElementType = cdrElementLine
+    ce(n / 2).PositionX = x
+    ce(n / 2).PositionY = Y
+  
+  Next
+  
+  Set crv = CreateCurve(ActiveDocument)
+  crv.CreateSubPathFromArray ce
+  ActiveLayer.CreateCurve crv
+  
+ErrorHandler:
+  API.EndOpt
+End Function

zerobase/ChatGPT.bas

@@ -1,7 +1,7 @@
 Attribute VB_Name = "ChatGPT"
 Private Type Coordinate
     x As Double
-    y As Double
+    Y As Double
 End Type
 
 Sub Z序排列()
@@ -15,9 +15,9 @@ Sub Z
   ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
   
   For Each s In ssr
-    dot.x = s.CenterX: dot.y = s.CenterY
+    dot.x = s.CenterX: dot.Y = s.CenterY
     s.OrderToFront
-    puts dot.x, dot.y, cnt: cnt = cnt + 1
+    puts dot.x, dot.Y, cnt: cnt = cnt + 1
   Next s
 End Sub
 
@@ -34,9 +34,9 @@ Sub U
   ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
   
   For Each s In ssr
-    dot.x = s.CenterX: dot.y = s.CenterY
+    dot.x = s.CenterX: dot.Y = s.CenterY
     If xdict.Exists(Int(dot.x)) = False Then xdict.Add Int(dot.x), dot.x
-    If ydict.Exists(Int(dot.y)) = False Then ydict.Add Int(dot.y), dot.y
+    If ydict.Exists(Int(dot.Y)) = False Then ydict.Add Int(dot.Y), dot.Y
   Next s
   
   inverter = 1   ' 交流频率控制
@@ -53,9 +53,9 @@ Sub U
   
   cnt = 1
   For Each s In ssr
-    dot.x = s.CenterX: dot.y = s.CenterY
+    dot.x = s.CenterX: dot.Y = s.CenterY
     s.OrderToFront
-    puts dot.x, dot.y, cnt: cnt = cnt + 1
+    puts dot.x, dot.Y, cnt: cnt = cnt + 1
   Next s
   
 End Sub
@@ -73,14 +73,14 @@ Sub
   ' 当前选择物件的范围边界
   set_lx = ssr.LeftX: set_rx = ssr.RightX
   set_by = ssr.BottomY: set_ty = ssr.TopY
-  ssr(1).GetSize Offset.x, Offset.y
+  ssr(1).GetSize Offset.x, Offset.Y
   ' 当前选择物件 ShapeRange 初步排序
   ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
   
   For Each s In ssr
-    dot.x = s.CenterX: dot.y = s.CenterY
+    dot.x = s.CenterX: dot.Y = s.CenterY
     If xdict.Exists(Int(dot.x)) = False Then xdict.Add Int(dot.x), dot.x
-    If ydict.Exists(Int(dot.y)) = False Then ydict.Add Int(dot.y), dot.y
+    If ydict.Exists(Int(dot.Y)) = False Then ydict.Add Int(dot.Y), dot.Y
   Next s
   
 '  MsgBox "字典使用计算行列:" & xdict.Count & ydict.Count
@@ -90,24 +90,24 @@ Sub
   Dim key As Variant
   For Each key In xdict.keys
       dot.x = xdict(key)
-      puts dot.x, set_by - Offset.y / 2, cnt
+      puts dot.x, set_by - Offset.Y / 2, cnt
       cnt = cnt + 1
   Next key
   
   cnt = 1
   For Each key In ydict.keys
-      dot.y = ydict(key)
-      puts set_lx - Offset.x / 2, dot.y, cnt
+      dot.Y = ydict(key)
+      puts set_lx - Offset.x / 2, dot.Y, cnt
       cnt = cnt + 1
   Next key
   
 End Sub
 
-Private Sub puts(x, y, n)
+Private Sub puts(x, Y, n)
   Dim st As String
   st = str(n)
   Set s = ActiveLayer.CreateArtisticText(0, 0, st)
-  s.CenterX = x: s.CenterY = y
+  s.CenterX = x: s.CenterY = Y
 End Sub
 
 '// 对数组进行排序[单维]
@@ -218,9 +218,9 @@ Sub
   ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
   
   For Each s In ssr
-    dot.x = s.CenterX: dot.y = s.CenterY
+    dot.x = s.CenterX: dot.Y = s.CenterY
     If xdict.Exists(Int(dot.x)) = False Then xdict.Add Int(dot.x), dot.x
-    If ydict.Exists(Int(dot.y)) = False Then ydict.Add Int(dot.y), dot.y
+    If ydict.Exists(Int(dot.Y)) = False Then ydict.Add Int(dot.Y), dot.Y
   Next s
   
   inverter = 1   ' 交流频率控制
@@ -237,9 +237,9 @@ Sub
   
   cnt = 1
   For Each s In ssr
-    dot.x = s.CenterX: dot.y = s.CenterY
+    dot.x = s.CenterX: dot.Y = s.CenterY
     s.OrderToFront
-    puts dot.x, dot.y, cnt: cnt = cnt + 1
+    puts dot.x, dot.Y, cnt: cnt = cnt + 1
   Next s
   
     ActiveDocument.EndCommandGroup

zerobase/Container.bas

@@ -1,39 +1,39 @@
 Attribute VB_Name = "Container"
-' 鈶� 鏍囪�瀹瑰櫒鐩掑瓙
+' ① 标记容器盒子
 Public Function SetBoxName()
-  API.BeginOpt "鏍囪�瀹瑰櫒鐩掑瓙"
+  API.BeginOpt "标记容器盒子"
   
-  Dim box As ShapeRange, S As Shape
+  Dim box As ShapeRange, s As Shape
   Set box = ActiveSelectionRange
   
-  ' 璁剧疆鐗╀欢鍚嶅瓧锛屼互渚汣QL鏌ヨ�
-  For Each S In box
-    S.Name = "Container"
-  Next S
+  ' 设置物件名字，以供CQL查询
+  For Each s In box
+    s.name = "Container"
+  Next s
   
   API.EndOpt
-  MsgBox "鏍囪�瀹瑰櫒鐩掑瓙" & vbNewLine & "鍚嶅瓧: Container"
+  MsgBox "标记容器盒子" & vbNewLine & "名字: Container"
 End Function
 
-' 鍥剧墖鎵归噺缃�叆瀹瑰櫒
+' 图片批量置入容器
 Public Sub Batch_ToPowerClip()
-  API.BeginOpt "鎵归噺缃�叆瀹瑰櫒"
-  Dim S As Shape, ssr As ShapeRange, box As ShapeRange
-  Set ssr = Smart_Group(0.5) ' 鏅鸿兘缇ょ粍瀹瑰樊 0.5mm
+  API.BeginOpt "批量置入容器"
+  Dim s As Shape, ssr As ShapeRange, box As ShapeRange
+  Set ssr = Smart_Group(0.5) ' 智能群组容差 0.5mm
   
-  For Each S In ssr
-    Image_ToPowerClip S
-  Next S
+  For Each s In ssr
+    Image_ToPowerClip s
+  Next s
 
   API.EndOpt
 End Sub
 
-' 鍥剧墖缃�叆瀹瑰櫒锛屽熀鏈�嚱鏁�
+' 图片置入容器，基本函数
 Public Function Image_ToPowerClip(arg As Shape)
   Dim box As ShapeRange
   Dim ssr As New ShapeRange, rmsr As New ShapeRange
   Set ssr = arg.UngroupEx
-  ' CQL鏌ユ壘瀹瑰櫒鐩掔墿浠�
+  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
@@ -41,224 +41,149 @@ Public Function Image_ToPowerClip(arg As Shape)
   
   box.SetOutlineProperties Width:=0, Color:=Nothing
   ssr.AddToPowerClip box(1), 0
-  box(1).Name = "powerclip_ok"
+  box(1).name = "powerclip_ok"
 
 End Function
 
-' 鍥剧墖OneKey缃�叆瀹瑰櫒
+' 图片OneKey置入容器
 Public Sub OneKey_ToPowerClip()
-  API.BeginOpt "鍥剧墖OneKey缃�叆瀹瑰櫒"
-  Dim S As Shape, ssr As ShapeRange, box As ShapeRange
+  API.BeginOpt "图片OneKey置入容器"
+  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"
-  Next S
+  For Each s In box
+    If s.Type <> cdrBitmapShape Then s.name = "Container"
+  Next s
   
-  Set ssr = Smart_Group(0.5) ' 鏅鸿兘缇ょ粍瀹瑰樊 0.5mm
+  Set ssr = Smart_Group(0.5) ' 智能群组容差 0.5mm
   
   Application.Optimization = True
-  For Each S In ssr
-    Image_ToPowerClip S
-  Next S
+  For Each s In ssr
+    Image_ToPowerClip s
+  Next s
 
   API.EndOpt
 End Sub
 
-' 鈶� 鍒犻櫎瀹瑰櫒鐩掑瓙杈圭晫澶栭潰鐨勭墿浠�    鈶⑩懀
-Public Function Remove_OutsideBox(radius As Double)
-  API.BeginOpt "鍒犻櫎瀹瑰櫒鐩掑瓙杈圭晫澶栭潰鐨勭墿"
-  On Error GoTo ErrorHandler
-  Dim S As Shape, bc As Shape
+' ② 删除容器盒子边界外面的物件    ③④
+Public Function Remove_OutsideBox()
+  Dim s As Shape
   Dim ssr As ShapeRange, box As ShapeRange
   Dim rmsr As New ShapeRange
   Dim x As Double, Y As Double
   
   Set ssr = ActiveSelectionRange
-  ' CQL鏌ユ壘瀹瑰櫒鐩掔墿浠�
+  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  If box.Count = 0 Then GoTo ErrorHandler
-  Set bc = box(1).Duplicate(0, 0)
-  If bc.Type = cdrTextShape Then bc.ConvertToCurves
-  
-  For Each S In ssr
-    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
+  If box.Count = 0 Then Exit Function
   
-Exit Function
-
-ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
+  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
+  Next s
 
+  rmsr.Delete
 End Function
 
-Public Function Select_OutsideBox(radius As Double)
-  On Error GoTo ErrorHandler
-  API.BeginOpt "閫夋嫨瀹瑰櫒澶栭潰瀵硅薄"
-  Dim S As Shape, bc As Shape
+
+Public Function Remove_OnMargin()
+  Dim s As Shape
   Dim ssr As ShapeRange, box As ShapeRange
-  Dim SelSr As New ShapeRange
+  Dim rmsr As New ShapeRange
   Dim x As Double, Y As Double
   
   Set ssr = ActiveSelectionRange
-  ' CQL鏌ユ壘瀹瑰櫒鐩掔墿浠�
+  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  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 bc.IsOnShape(x, Y, S.SizeWidth / 2 * radius) = cdrOutsideShape Then SelSr.Add S
-  Next S
-  
-  ActiveDocument.ClearSelection
-  bc.Delete: SelSr.AddToSelection: API.EndOpt
+  If box.Count = 0 Then Exit Function
   
-Exit Function
+  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
+  Next s
 
-ErrorHandler:
-  Application.Optimization = False
+  rmsr.Delete
 End Function
 
-Public Function Select_by_BlendGroup(radius As Double)
-  On Error GoTo ErrorHandler
-  API.BeginOpt "浣跨敤璋冨拰缇ょ粍閫夋嫨"
-  Dim S As Shape, bc As Shape
-  Dim ssr As ShapeRange, box As ShapeRange, gp As ShapeRange
+
+Public Function Select_OutsideBox()
+  Dim s As Shape
+  Dim ssr As ShapeRange, box As ShapeRange
   Dim SelSr As New ShapeRange
-  Dim x As Double, Y As Double
+  Dim x As Double, Y As Double, radius
   
   Set ssr = ActiveSelectionRange
-  ' CQL鏌ユ壘瀹瑰櫒鐩掔墿浠�
+  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  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
-    If bc.IsOnShape(x, Y, S.SizeWidth / 2 * radius) = cdrOnMarginOfShape Then SelSr.Add S
-  Next S
+  If box.Count = 0 Then Exit Function
   
-  ActiveDocument.ClearSelection
-  bc.Delete: SelSr.AddToSelection: API.EndOpt
+  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
+  Next s
   
-Exit Function
+  ActiveDocument.ClearSelection
+  SelSr.AddToSelection
 
-ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
 End Function
 
-Public Function Select_OnMargin(radius As Double)
-  On Error GoTo ErrorHandler
-  API.BeginOpt "閫夋嫨瀹瑰櫒杈圭晫瀵硅薄"
-  Dim S As Shape, bc As Shape
+
+Public Function Select_OnMargin()
+  Dim s As Shape
   Dim ssr As ShapeRange, box As ShapeRange
   Dim SelSr As New ShapeRange
-  Dim x As Double, Y As Double
+  Dim x As Double, Y As Double, radius
   
   Set ssr = ActiveSelectionRange
-  ' CQL鏌ユ壘瀹瑰櫒鐩掔墿浠�
+  ' CQL查找容器盒物件
   Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
   ssr.RemoveRange box
   
-  If box.Count = 0 Then GoTo ErrorHandler
-  Set bc = box(1).Duplicate(0, 0)
-  If bc.Type = cdrTextShape Then bc.ConvertToCurves  ' 濡傛灉鏄�枃鏈�浆鏇�
-
+  If box.Count = 0 Then Exit Function
   
-  ActiveDocument.unit = cdrMillimeter
-  For Each S In ssr
-    x = S.CenterX: Y = S.CenterY
-    If bc.IsOnShape(x, Y, S.SizeWidth / 2 * radius) = cdrOnMarginOfShape Then SelSr.Add S
-  Next S
+  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
+  Next s
   
   ActiveDocument.ClearSelection
-  bc.Delete: SelSr.AddToSelection: API.EndOpt
-  
-Exit Function
+  SelSr.AddToSelection
 
-ErrorHandler:
-  Application.Optimization = False
-  On Error Resume Next
-  
 End Function
 
 
-Private Function Smart_Group(Optional ByVal tr As Double = 0) As ShapeRange
-If 0 = ActiveSelectionRange.Count Then Exit Function
-  On Error GoTo ErrorHandler
-  Application.Optimization = True
-  ActiveDocument.ReferencePoint = cdrBottomLeft
-  ActiveDocument.unit = cdrMillimeter
-  
-  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
-
-  '// 鏌ユ壘杞寸嚎杞�粨
-  ActivePage.Shapes.FindShapes(Query:="@Outline.Color=RGB(26, 22, 35)").CreateSelection
-  ActivePage.Shapes.FindShapes(Query:="@fill.Color=RGB(26, 22, 35)").AddToSelection
-  For Each sh In ActiveSelection.Shapes
-     sr.Add sh
-  Next sh
-  
-  '// 鏂扮煩褰㈠�鎵捐竟鐣岋紝鏁ｅ紑锛屽垹闄ゅ垰鎵嶇敾鐨勬柊鐭╁舰
-  Set s1 = sr.CustomCommand("Boundary", "CreateBoundary")
-  Set brk1 = s1.BreakApartEx
-  sr.Delete
-
-  '// 鐭╁舰杈圭晫鏅鸿兘缇ょ粍, retsr 杩斿洖缇ょ粍 鍜� 鍒犻櫎鐭╁舰s
-  Dim retsr As New ShapeRange, rmsr As New ShapeRange
-  For Each S In brk1
-    Set sh = ActivePage.SelectShapesFromRectangle(S.LeftX, S.TopY, S.RightX, S.BottomY, False)
-    S.Delete
-    retsr.Add sh.Shapes.All.group
-  Next
-
-  Set Smart_Group = retsr
-  
-  Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
-Exit 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
 
-ErrorHandler:
-  Application.Optimization = False
-  MsgBox "璇峰厛閫夋嫨涓€浜涚墿浠舵潵纭�畾缇ょ粍鑼冨洿!"
-  On Error Resume Next
 
+' 以下函数，解散物件，以面积排序居中
+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
 

zerobase/PhotoForm.frm

@@ -7,7 +7,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} PhotoForm
    ClientWidth     =   4710
    OleObjectBlob   =   "PhotoForm.frx":0000
    ShowModal       =   0   'False
-   StartUpPosition =   1  'ËùÓÐÕßÖÐÐÄ
+   StartUpPosition =   1  'CenterOwner
 End
 Attribute VB_Name = "PhotoForm"
 Attribute VB_GlobalNameSpace = False

zerobase/ThisMacroStorage.cls

@@ -0,0 +1,9 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ThisMacroStorage"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True

zerobase/Tools.bas

@@ -9,76 +9,77 @@ Public Function wait()
   Sleep 3000
 End Function
 
-Public Sub 濉�叆灞呬腑鏂囧瓧(str)
+
+Public Sub 填入居中文字(str)
   Dim s As Shape
-  Dim x As Double, y As Double, Shift As Long
+  Dim x As Double, Y As Double, Shift As Long
   Dim b As Boolean
-  b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorIntersectSingle)
+  b = ActiveDocument.GetUserClick(x, Y, Shift, 10, False, cdrCursorIntersectSingle)
   
   str = VBA.Replace(str, vbNewLine, Chr(10))
   str = VBA.Replace(str, Chr(10), vbNewLine)
   Set s = ActiveLayer.CreateArtisticText(0, 0, str)
   s.CenterX = x
-  s.CenterY = y
+  s.CenterY = Y
 End Sub
 
-Public Sub 灏哄�鏍囨敞()
+Public Sub 尺寸标注()
   ActiveDocument.Unit = cdrMillimeter
   Set s = ActiveSelection
-  x = s.CenterX: y = s.TopY
+  x = s.CenterX: Y = s.TopY
   sw = s.SizeWidth: sh = s.SizeHeight
         
   text = Int(sw) & "x" & Int(sh) & "mm"
   Set s = ActiveLayer.CreateArtisticText(0, 0, text)
-  s.CenterX = x: s.BottomY = y + 5
+  s.CenterX = x: s.BottomY = Y + 5
 End Sub
 
-Public Sub 鎵归噺灞呬腑鏂囧瓧(str)
+Public Sub 批量居中文字(str)
   Dim s As Shape, sr As ShapeRange
   Set sr = ActiveSelectionRange
   
   For Each s In sr.Shapes
-    x = s.CenterX: y = s.CenterY
+    x = s.CenterX: Y = s.CenterY
     
     Set s = ActiveLayer.CreateArtisticText(0, 0, str)
-    s.CenterX = x: s.CenterY = y
+    s.CenterX = x: s.CenterY = Y
   Next
 End Sub
 
-Public Sub 鎵归噺鏍囨敞()
+Public Sub 批量标注()
   ActiveDocument.Unit = cdrMillimeter
   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"
     Set s = ActiveLayer.CreateArtisticText(0, 0, text)
-    s.CenterX = x: s.BottomY = y + 5
+    s.CenterX = x: s.BottomY = Y + 5
   Next
 End Sub
 
-Public Sub 鏅鸿兘缇ょ粍()
+Public Sub 智能群组()
   Set s1 = ActiveSelectionRange.CustomCommand("Boundary", "CreateBoundary")
   Set brk1 = s1.BreakApartEx
 
   For Each s In brk1
     Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, True)
-    sh.Shapes.All.group
+    sh.Shapes.All.Group
     s.Delete
   Next
 End Sub
 
 
-' 瀹炶返搴旂敤: 閫夋嫨鐗╀欢缇ょ粍,椤甸潰璁剧疆鐗╀欢澶у皬,鐗╀欢椤甸潰灞呬腑
-Public Function 缇ょ粍灞呬腑椤甸潰()
+' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
+Public Function 群组居中页面()
   ActiveDocument.Unit = cdrMillimeter
   Dim OrigSelection As ShapeRange, sh As Shape
   Set OrigSelection = ActiveSelectionRange
-  Set sh = OrigSelection.group
+  Set sh = OrigSelection.Group
   
-  ' MsgBox "閫夋嫨鐗╀欢灏哄�: " & sh.SizeWidth & "x" & sh.SizeHeight
+  ' MsgBox "选择物件尺寸: " & sh.SizeWidth & "x" & sh.SizeHeight
   ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
   
 #If VBA7 Then
@@ -92,7 +93,7 @@ Public Function 缇ょ粍灞呬腑椤甸潰()
 End Function
 
 
-Public Function 鎵归噺澶氶〉灞呬腑()
+Public Function 批量多页居中()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
@@ -101,19 +102,19 @@ Public Function 鎵归噺澶氶〉灞呬腑()
   Set sr = ActiveSelectionRange
   total = sr.Count
 
-  '// 寤虹珛澶氶〉闈�
+  '// 建立多页面
   Set doc = ActiveDocument
   doc.AddPages (total - 1)
 
   Dim sh As Shape
   
-  '// 閬嶅巻鎵归噺鐗╀欢锛屾斁缃�墿浠跺埌椤甸潰
+  '// 遍历批量物件，放置物件到页面
   For i = 1 To sr.Count
     doc.Pages(i).Activate
     Set sh = sr.Shapes(i)
     ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
  
-   '// 鐗╀欢灞呬腑椤甸潰
+   '// 物件居中页面
 #If VBA7 Then
   ActiveDocument.ClearSelection
   sh.AddToSelection
@@ -130,12 +131,12 @@ Exit Function
 
 ErrorHandler:
   Application.Optimization = False
-  MsgBox "璇峰厛閫夋嫨涓€浜涚墿浠�"
+  MsgBox "请先选择一些物件"
   On Error Resume Next
 End Function
 
 
-'// 瀹夊叏绾�: 鐐瑰嚮涓€娆″缓绔嬭緟鍔╃嚎锛屽啀璋冪敤娓呴櫎鍙傝€冪嚎
+'// 安全线: 点击一次建立辅助线，再调用清除参考线
 Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
   Dim sr As ShapeRange
   Set sr = ActiveDocument.MasterPage.GuidesLayer.FindShapes(Type:=cdrGuidelineShape)
@@ -164,11 +165,11 @@ End Function
 
 
 Public Function vba_cnt()
-  VBA_FORM.text1 = VBA_FORM.text1 & ">"
+  ' VBA_FORM.text1 = VBA_FORM.text1 & ">"
   Sleep 100
 End Function
 
-Public Function 鎸夐潰绉�帓鍒�(space_width As Double)
+Public Function 按面积排列(space_width As Double)
   If 0 = ActiveSelectionRange.Count Then Exit Function
   ActiveDocument.Unit = cdrMillimeter
   ActiveDocument.ReferencePoint = cdrCenter
@@ -179,7 +180,7 @@ Public Function 鎸夐潰绉�帓鍒�(space_width As Double)
 #If VBA7 Then
   ssr.Sort "@shape1.width * @shape1.height < @shape2.width * @shape2.height"
 #Else
-' X4 涓嶆敮鎸� ShapeRange.sort
+' X4 不支持 ShapeRange.sort
 #End If
 
   Dim str As String, size As String
@@ -200,23 +201,23 @@ Public Function 鎸夐潰绉�帓鍒�(space_width As Double)
   Next s
 
 
-'  鍐欐枃浠讹紝鍙�互EXCEL閲岀粺璁�
+'  写文件，可以EXCEL里统计
 '  Set fs = CreateObject("Scripting.FileSystemObject")
 '  Set f = fs.CreateTextFile("D:\size.txt", True)
 '  f.WriteLine str: f.Close
 
-  str = 鍒嗙被姹囨€�(str)
+  str = 分类汇总(str)
   Debug.Print str
 
   Dim s1 As Shape
-' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="鍗庢枃涓�畫")
+' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
   x = ssr.FirstShape.LeftX - 100
-  y = ssr.FirstShape.TopY
-  Set s1 = ActiveLayer.CreateParagraphText(x, y, x + 90, y - 150, str, Font:="鍗庢枃涓�畫")
+  Y = ssr.FirstShape.TopY
+  Set s1 = ActiveLayer.CreateParagraphText(x, Y, x + 90, Y - 150, str, Font:="华文中宋")
 End Function
  
-'// 瀹炵幇Excel閲屽垎绫绘眹鎬诲姛鑳�
-Private Function 鍒嗙被姹囨€�(str As String) As String
+'// 实现Excel里分类汇总功能
+Private Function 分类汇总(str As String) As String
   Dim a, b, d, arr
   str = VBA.Replace(str, vbNewLine, " ")
   Do While InStr(str, "  ")
@@ -234,30 +235,30 @@ Private Function 鍒嗙被姹囨€�(str As String) As String
     End If
   Next
 
-  str = "   瑙�   鏍�" & vbTab & vbTab & vbTab & "鏁伴噺" & vbNewLine
+  str = "   规   格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
 
   a = d.keys: b = d.items
   For i = 0 To d.Count - 1
     ' Debug.Print a(i), b(i)
-    str = str & a(i) & vbTab & vbTab & b(i) & "鏉�" & vbNewLine
+    str = str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
   Next
 
-  鍒嗙被姹囨€� = str & "鍚堣�鎬婚噺:" & vbTab & vbTab & vbTab & UBound(arr) & "鏉�" & vbNewLine
+  分类汇总 = str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
 End Function
 
 
-' 涓や釜绔�偣鐨勫潗鏍�,涓�(x1,y1)鍜�(x2,y2) 閭ｄ箞鍏惰�搴�鐨則an鍊�: tana=(y2-y1)/(x2-x1)
-' 鎵€浠ヨ�绠梐rctan(y2-y1)/(x2-x1), 寰楀埌鍏惰�搴﹀€糰
-' VB涓�敤atn(), 杩斿洖鍊兼槸寮у害锛岄渶瑕� 涔樹互 PI /180
+' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
+' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
+' VB中用atn(), 返回值是弧度，需要 乘以 PI /180
 Private Function lineangle(x1, y1, x2, y2) As Double
-  pi = 4 * VBA.Atn(1) ' 璁＄畻鍦嗗懆鐜�
+  pi = 4 * VBA.Atn(1) ' 计算圆周率
   If x2 = x1 Then
     lineangle = 90: Exit Function
   End If
   lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
 End Function
 
-Public Function 瑙掑害杞�钩()
+Public Function 角度转平()
   On Error GoTo ErrorHandler
 '  ActiveDocument.ReferencePoint = cdrCenter
   Set sr = ActiveSelectionRange
@@ -267,12 +268,12 @@ Public Function 瑙掑害杞�钩()
     x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
     x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
     a = lineangle(x1, y1, x2, y2): sr.Rotate -a
-    ' sr.LastShape.Delete   '// 鍒犻櫎鍙傝€冪嚎
+    ' sr.LastShape.Delete   '// 删除参考线
   End If
 ErrorHandler:
 End Function
 
-Public Function 鑷�姩鏃嬭浆瑙掑害()
+Public Function 自动旋转角度()
   On Error GoTo ErrorHandler
 '  ActiveDocument.ReferencePoint = cdrCenter
   Set sr = ActiveSelectionRange
@@ -282,22 +283,22 @@ Public Function 鑷�姩鏃嬭浆瑙掑害()
     x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
     x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
     a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
-    sr.LastShape.Delete   '// 鍒犻櫎鍙傝€冪嚎
+    sr.LastShape.Delete   '// 删除参考线
   End If
 ErrorHandler:
 End Function
 
 
-Public Function 浜ゆ崲瀵硅薄()
+Public Function 交换对象()
   Set sr = ActiveSelectionRange
   If sr.Count = 2 Then
-    x = sr.LastShape.CenterX: y = sr.LastShape.CenterY
+    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
+    sr.FirstShape.CenterX = x: sr.FirstShape.CenterY = Y
   End If
 End Function
 
-Public Function 鍙傝€冪嚎闀滃儚()
+Public Function 参考线镜像()
   On Error GoTo ErrorHandler
   Set sr = ActiveSelectionRange
   Set nr = sr.LastShape.DisplayCurve.Nodes.All
@@ -307,26 +308,26 @@ Public Function 鍙傝€冪嚎闀滃儚()
     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
+    a = lineangle(x1, y1, x2, y2)  '// 参考线和水平的夹角 a
     sr.Remove sr.Count
     
-    ang = 90 - a  ' 闀滃儚鐨勬棆杞��搴�
+    ang = 90 - a  ' 镜像的旋转角度
     For Each s In sr
       With s
-        .Duplicate   ' // 澶嶅埗鐗╀欢淇濈暀锛岀劧鍚庢寜 x1,y1 鐐� 鏃嬭浆
+        .Duplicate   ' // 复制物件保留，然后按 x1,y1 点 旋转
         .RotationCenterX = x1
         .RotationCenterY = y1
         .Rotate ang
         If Not byshape Then
             lx = .LeftX
-            .Stretch -1#, 1#    ' // 閫氳繃鎷変几瀹屾垚闀滃儚
+            .Stretch -1#, 1#    ' // 通过拉伸完成镜像
             .LeftX = lx
             .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
-            .RotationCenterX = x1   '// 涔嬪墠鍥犱负闀滃儚锛屾棆杞�腑蹇冪偣鍙嶄簡锛岄噸缃�洖鏉�
+            .RotationCenterX = x1   '// 之前因为镜像，旋转中心点反了，重置回来
             .RotationCenterY = y1
             .Rotate -ang
         End If
-        .RotationCenterX = .CenterX   '// 閲嶇疆鍥炴棆杞�腑蹇冪偣涓虹墿浠朵腑蹇�
+        .RotationCenterX = .CenterX   '// 重置回旋转中心点为物件中心
         .RotationCenterY = .CenterY
       End With
     Next s
@@ -336,7 +337,7 @@ ErrorHandler:
 End Function
 
 
-Public Function autogroup(Optional group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
+Public Function autogroup(Optional Group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
   Dim sr As ShapeRange, sr_all As ShapeRange, os As ShapeRange
   Dim sp As SubPaths
   Dim arr()
@@ -396,8 +397,8 @@ Public Function autogroup(Optional group As String = "group", Optional shft = 0,
         End If
       Next j
       If inar > 1 Then
-        If group = "group" Then
-          If shft < 4 Then sr_all.Add sr.group
+        If Group = "group" Then
+          If shft < 4 Then sr_all.Add sr.Group
         End If
       Else
         If sr.Shapes.Count > 0 Then sr_all.AddRange sr
@@ -445,7 +446,7 @@ Sub Make_Sizes()
     End If
 End Sub
 
-'''////  閫夋嫨澶氱墿浠讹紝缁勫悎鐒跺悗鎷嗗垎绾挎�锛屼负瑙掔嚎鐖�櫕鍑嗗�  ////'''
+'''////  选择多物件，组合然后拆分线段，为角线爬虫准备  ////'''
 Public Function Split_Segment()
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
@@ -475,7 +476,7 @@ ErrorHandler:
 End Function
 
 
-'// 淇��鍦嗚�缂鸿�鍒扮洿瑙�
+'// 修复圆角缺角到直角
 Public Sub corner_off()
     Dim os As ShapeRange
     Dim s As Shape, fir As Shape, ci As Shape
@@ -620,37 +621,37 @@ End Sub
 Sub ExportNodePositions()
     Dim s As Shape, n As Node
     Dim srActiveLayer As ShapeRange
-    Dim x As Double, y As Double
+    Dim x As Double, Y As Double
     Dim strNodePositions As String
     
     ActiveDocument.Unit = cdrMillimeter
     
     'Get all the curve shapes on the Active Layer
-    '鑾峰彇Active Layer涓婄殑鎵€鏈夋洸绾垮舰鐘�
+    '获取Active Layer上的所有曲线形状
     Set srActiveLayer = ActiveLayer.Shapes.FindShapes(Query:="@type='curve'")
     'This is another way you can get only the curve shapes
-    '杩欐槸鍙︿竴绉嶄綘鍙�兘寰楀埌鏇茬嚎褰㈢姸鐨勬柟娉�
+    '这是另一种你只能得到曲线形状的方法
     'Set srActiveLayer = ActiveLayer.Shapes.FindShapes.FindAnyOfType(cdrCurveShape)
     
     'Loop through each curve
-    '閬嶅巻姣忔潯鏇茬嚎
+    '遍历每条曲线
     For Each s In srActiveLayer.Shapes
         'Loop though each node in the curve and get the position
-        '閬嶅巻鏇茬嚎涓�殑姣忎釜鑺傜偣骞惰幏鍙栦綅缃�
+        '遍历曲线中的每个节点并获取位置
         For Each n In s.Curve.Nodes
-            n.GetPosition x, y
-            strNodePositions = strNodePositions & "x: " & x & " y: " & y & vbCrLf
+            n.GetPosition x, Y
+            strNodePositions = strNodePositions & "x: " & x & " y: " & Y & vbCrLf
         Next n
     Next s
     
     'Save the node positions to a file
-    '灏嗚妭鐐逛綅缃�繚瀛樺埌鏂囦欢
+    '将节点位置保存到文件
     Open "C:\Temp\NodePositions.txt" For Output As #1
         Print #1, strNodePositions
     Close #1
 End Sub
 
-Sub 鏈嶅姟鍣═()
+Sub 服务器T()
    Dim mark As Shape
    Dim sr As ShapeRange
    
@@ -659,9 +660,9 @@ Sub 鏈嶅姟鍣═()
         sr.Shapes.FindShapes(Query:="@type ='rectangle'or @type ='curve'or @type ='Ellipse'or @type ='Polygon'").ConvertToCurves
    If sr.Count = 0 Then Exit Sub
    
-    ' CorelDRAW璁剧疆鍘熺偣鏍囪�瀵煎嚭DXF浣跨敤
+    ' CorelDRAW设置原点标记导出DXF使用
     
-    ' 鏇存柊鍘熺偣鏍囪�锛岀幇鍦ㄨ兘璁剧疆浠绘剰鍧愭爣鐐�
+    ' 更新原点标记，现在能设置任意坐标点
     Dim MarkPos_Array() As Double
     MarkPos_Array = Get_MarkPosition
     AtOrigin MarkPos_Array(0), MarkPos_Array(1)
@@ -702,50 +703,50 @@ Sub SaveDXF(FileName As String)
     End With
 End Sub
 
-' 鏇存柊鍘熺偣鏍囪�鍑芥暟锛岀幇鍦ㄨ兘璁剧疆浠绘剰鍧愭爣鐐�
+' 更新原点标记函数，现在能设置任意坐标点
 Sub AtOrigin(Optional px As Double = 0#, Optional py As Double = 0#)
   Dim doc As Document: Set doc = ActiveDocument
   doc.Unit = cdrMillimeter
 
-  '// 瀵煎叆鍘熺偣鏍囪�鏍囪�鏂囦欢 OriginMark.cdr 瑙ｆ暎缇ょ粍
+  '// 导入原点标记标记文件 OriginMark.cdr 解散群组
   doc.ActiveLayer.Import path & "GMS\OriginMark.cdr"
   doc.ReferencePoint = cdrCenter
   doc.Selection.Ungroup
 
   Dim sh As Shape, shs As Shapes
   Set shs = ActiveSelection.Shapes
-  '// 鎸� MarkName 鍚嶇О鏌ユ壘 鏍囪�鐗╀欢
+  '// 按 MarkName 名称查找 标记物件
   For Each sh In shs
     If "AtOrigin" = sh.ObjectData("MarkName").Value Then
       sh.SetPosition px, py
     Else
-      sh.Delete   ' 涓嶉渶瑕佺殑鏍囪�鍒犻櫎
+      sh.Delete   ' 不需要的标记删除
     End If
   Next sh
 End Sub
 
-' 浣跨敤 GlobalUserData 瀵硅薄淇濆瓨 Mark鏍囪�鍧愭爣鏂囨湰锛岃皟鐢ㄥ嚱鏁拌兘璁剧疆鏂囨湰
+' 使用 GlobalUserData 对象保存 Mark标记坐标文本，调用函数能设置文本
 Public Function Mark_SetPosition() As String
   Dim text As String
   If GlobalUserData.Exists("MarkPosition", 1) Then
     text = GlobalUserData("MarkPosition", 1)
   End If
-  text = InputBox("璇疯緭鍏�ark鏍囪�鍧愭爣(x,y),绌烘牸鎴栭€楀彿闂撮殧", "璁剧疆Mark鏍囪�鍧愭爣(x,y),鍗曚綅(mm)", text)
+  text = InputBox("请输入Mark标记坐标(x,y),空格或逗号间隔", "设置Mark标记坐标(x,y),单位(mm)", text)
   If text = "" Then Exit Function
   GlobalUserData("MarkPosition", 1) = text
   Mark_SetPosition = text
 End Function
 
-' 璋冪敤璁剧疆Mark鏍囪�鍧愭爣鍔熻兘锛岃繑鍥� 鏁扮粍(x,y)
+' 调用设置Mark标记坐标功能，返回 数组(x,y)
 Public Function Get_MarkPosition() As Double()
   Dim MarkPos_Array(0 To 1) As Double
   Dim str, arr
   
   str = Mark_SetPosition
 
-  ' 鏇挎崲 閫楀彿 涓虹┖鏍�
+  ' 替换 逗号 为空格
   str = VBA.Replace(str, ",", " ")
-  Do While InStr(str, "  ") '澶氫釜绌烘牸鎹㈡垚涓€涓�┖鏍�
+  Do While InStr(str, "  ") '多个空格换成一个空格
       str = VBA.Replace(str, "  ", " ")
   Loop
   arr = Split(str)
@@ -753,7 +754,7 @@ Public Function Get_MarkPosition() As Double()
   MarkPos_Array(0) = Val(arr(0))
   MarkPos_Array(1) = Val(arr(1))
   
-  Debug.Print MarkPos_Array(0), MarkPos_Array(1)  ' 瑙嗗浘->绔嬪嵆绐楀彛锛岃皟璇曟樉绀�
+  Debug.Print MarkPos_Array(0), MarkPos_Array(1)  ' 视图->立即窗口，调试显示
   
   Get_MarkPosition = MarkPos_Array
   
@@ -766,12 +767,12 @@ Public Function SetNames()
 #If VBA7 Then
   ssr.Sort " @shape1.left<@shape2.left"
 #Else
-' X4 涓嶆敮鎸� ShapeRange.sort
+' X4 不支持 ShapeRange.sort
 #End If
 
   Dim text As String
   Dim lines() As String
-  ' 鎻愬彇鏂囨湰淇℃伅锛屽垏鍓叉枃鏈�
+  ' 提取文本信息，切割文本
   If ssr(1).Type = cdrTextShape Then
     If ssr(1).text.Type = cdrArtistic Then
       text = ssr(1).text.Story.text
@@ -780,25 +781,25 @@ Public Function SetNames()
   #If VBA7 Then
       ssr.Sort " @shape1.top>@shape2.top"
   #Else
-  ' X4 涓嶆敮鎸� ShapeRange.sort
+  ' X4 不支持 ShapeRange.sort
   #End If
     End If
   Else
-      MsgBox "璇锋妸澶氳�鏂囨湰鏀炬渶宸﹁竟"
+      MsgBox "请把多行文本放最左边"
       Exit Function
   End If
     
 ' Debug.Print ssr.Count, UBound(lines), LBound(lines)
-' 缁欑墿浠惰�缃�悕绉帮紝鐢ㄥ�:鎵归噺瀵煎嚭鍙�互鏈変竴涓�悕绉�
+' 给物件设置名称，用处:批量导出可以有一个名称
   i = 0
   If ssr.Count <= UBound(lines) + 1 Then
     For Each s In ssr
-      s.Name = lines(i)
+      s.name = lines(i)
       i = i + 1
     Next s
   End If
   
-  If ssr.Count <> UBound(lines) + 1 Then MsgBox "鏂囨湰琛�:" & (UBound(lines) + 1) & vbNewLine & "鍙宠竟鐗╀欢:" & ssr.Count
+  If ssr.Count <> UBound(lines) + 1 Then MsgBox "文本行:" & (UBound(lines) + 1) & vbNewLine & "右边物件:" & ssr.Count
     
 End Function
 
@@ -825,12 +826,4 @@ Sub Nodes_TO_TSP()
     f.Close
 End Sub
 
-'// 鑾峰緱鍓�创鏉挎枃鏈�瓧绗�
-Public Function GetClipBoardString() As String
-  On Error Resume Next
-  Dim MyData As New DataObject
-  GetClipBoardString = ""
-  MyData.GetFromClipboard
-  GetClipBoardString = MyData.GetText
-  Set MyData = Nothing
-End Function
+

zerobase/VBA_FORM.frm

@@ -6,7 +6,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} VBA_FORM
    ClientTop       =   390
    ClientWidth     =   6180
    OleObjectBlob   =   "VBA_FORM.frx":0000
-   StartUpPosition =   1  '鎵€鏈夎€呬腑蹇�
+   StartUpPosition =   1  'CenterOwner
 End
 Attribute VB_Name = "VBA_FORM"
 Attribute VB_GlobalNameSpace = False
@@ -15,7 +15,7 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 Private Sub AutoRotate_Click()
-  Tools.鑷�姩鏃嬭浆瑙掑害
+  Tools.自动旋转角度
 End Sub
 
 Private Sub btn_autoalign_bycolumn_Click()
@@ -26,6 +26,22 @@ Private Sub btn_corners_off_Click()
   Tools.corner_off
 End Sub
 
+Private Sub btn_ExpandForm_Click()
+  With Me
+    If .Width = 200 Then
+      .Width = 260: .Height = 132
+    ElseIf .Height = 132 Then
+      .Height = 206
+    Else
+      .Width = 200: .Height = 105
+    End If
+  End With
+End Sub
+
+Private Sub cmd_Batch_Center_Click()
+  Container.Batch_Center
+End Sub
+
 Private Sub CommandButton1_Click()
   autogroup("group", 2).CreateSelection
 End Sub
@@ -33,29 +49,29 @@ End Sub
 
 Private Sub CB_AQX_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, 4    ' 宸﹂敭瀹夊叏鑼冨洿 4mm
+    Tools.guideangle ActiveSelectionRange, 4    ' 左键安全范围 4mm
   Else
-    Tools.guideangle ActiveSelectionRange, -10     ' Ctrl + 榧犳爣宸﹂敭
+    Tools.guideangle ActiveSelectionRange, -10     ' Ctrl + 鼠标左键
   End If
 End Sub
 
 Private Sub CB_BZCC_Click()
-  Tools.灏哄�鏍囨敞
+  Tools.尺寸标注
 End Sub
 
 
 Private Sub CB_ECWZ_Click()
-  Tools.濉�叆灞呬腑鏂囧瓧 GetClipBoardString
+  Tools.填入居中文字 GetClipBoardString
 End Sub
 
 Private Sub CB_JDZP_Click()
-  Tools.瑙掑害杞�钩
+  Tools.角度转平
 End Sub
 
 Private Sub CB_JHDX_Click()
-  Tools.浜ゆ崲瀵硅薄
+  Tools.交换对象
 End Sub
 
 Private Sub CB_make_sizes_Click()
@@ -63,19 +79,19 @@ Private Sub CB_make_sizes_Click()
 End Sub
 
 Private Sub CB_PLBZ_Click()
-  Tools.鎵归噺鏍囨敞
+  Tools.批量标注
 End Sub
 
 Private Sub CB_PLDYJZ_Click()
-  Tools.鎵归噺澶氶〉灞呬腑
+  Tools.批量多页居中
 End Sub
 
 Private Sub CB_PLWZ_Click()
-  Tools.鎵归噺灞呬腑鏂囧瓧 "CorelVBA鎵归噺鏂囧瓧"
+  Tools.批量居中文字 "CorelVBA批量文字"
 End Sub
 
 Private Sub CB_QZJZ_Click()
-  Tools.缇ょ粍灞呬腑椤甸潰
+  Tools.群组居中页面
 End Sub
 
 
@@ -84,7 +100,7 @@ Private Sub CB_SIZESORT_Click()
 End Sub
 
 Private Sub CB_VBA_Click()
-  MsgBox "浣犲ソ CorelVBA!"
+  MsgBox "你好 CorelVBA!"
 End Sub
 
 Private Sub CB_VBA_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
@@ -93,16 +109,16 @@ End Sub
 
 
 Private Sub CB_ZDJD_Click()
-  Tools.鑷�姩鏃嬭浆瑙掑害
+  Tools.自动旋转角度
 End Sub
 
 Private Sub CB_mirror_by_line_Click()
-  Tools.鍙傝€冪嚎闀滃儚
+  Tools.参考线镜像
 End Sub
 
 
 Private Sub CommandButton2_Click()
-  Tools.鏈嶅姟鍣═
+  Tools.服务器T
 End Sub
 
 Private Sub CommandButton3_Click()
@@ -113,10 +129,10 @@ Private Sub CommandButton3_Click()
     Set shr = ActivePage.Shapes.All
 
     If sr.Shapes.Count = 0 Then
-        shr.CreateSelection '鎵€鏈夊�璞�
+        shr.CreateSelection '所有对象
     Else
         shr.RemoveRange sr
-        shr.CreateSelection '涓嶅湪鍘熼€夋嫨鑼冨洿鍐呯殑瀵硅薄
+        shr.CreateSelection '不在原选择范围内的对象
     End If
 End Sub
 
@@ -124,6 +140,17 @@ Private Sub ExportNodePot_Click()
   Tools.ExportNodePositions
 End Sub
 
+Private Sub Image7_Click()
+arrow.Show 0
+Unload Me
+End Sub
+
+Private Sub Image8_Click()
+    frmSelectSame.Show 0
+    Unload Me
+End Sub
+
+
 Private Sub OneKeyToPowerClip_Click()
   Container.OneKey_ToPowerClip
 End Sub
@@ -136,27 +163,33 @@ Private Sub BatchToPowerClip_Click()
   Container.Batch_ToPowerClip
 End Sub
 
-Private Sub RemoveShapes_OutsideBox_Click()
-  Container.Remove_OutsideBox Create_Tolerance
-End Sub
 
-Private Sub SelectOnMargin_Click()
-  Container.Select_OnMargin Create_Tolerance
+Private Sub Print_Page_Click()
+  ActivePage.Shapes.All.Move ActivePage.CenterX - ActiveSelectionRange.CenterX, ActivePage.CenterY - ActiveSelectionRange.CenterY
+  
+  ' 等价下面几行代码
+  ' Dim sr As ShapeRange, shr As ShapeRange
+  ' Set sr = ActiveSelectionRange
+  ' Set shr = ActivePage.Shapes.All
+  
+  ' X = sr.CenterX
+  ' Y = sr.CenterY
+  ' px = ActivePage.CenterX
+  ' py = ActivePage.CenterY
+  ' shr.Move px - X, py - Y
+  
 End Sub
 
-
-Private Sub cmd_Select_by_BlendGroup_Click()
-  If GlobalUserData.Exists("Tolerance", 1) Then text = GlobalUserData("Tolerance", 1)
-  Container.Select_by_BlendGroup Val(text)
+Private Sub RemoveShapes_OutsideBox_Click()
+  Container.Remove_OutsideBox
 End Sub
 
-Private Sub SelectOnMargin_Q_Click()
-  If GlobalUserData.Exists("Tolerance", 1) Then text = GlobalUserData("Tolerance", 1)
-  Container.Select_OnMargin Val(text)
+Private Sub SelectOnMargin_Click()
+  Container.Select_OnMargin
 End Sub
 
 Private Sub SelectOutsideBox_Click()
-  Container.Select_OutsideBox Create_Tolerance
+  Container.Select_OutsideBox
 End Sub
 
 Private Sub Set_BoxName_Click()
@@ -169,7 +202,7 @@ End Sub
 
 Private Sub SplitSegment_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
@@ -179,7 +212,7 @@ Private Sub SplitSegment_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
 End Sub
 
 Private Sub Image4_Click()
-    cmd_line = "Notepad  D:\澶囧繕褰�.txt"
+    cmd_line = "Notepad  D:\备忘录.txt"
     Shell cmd_line, vbNormalNoFocus
 End Sub
 
@@ -188,7 +221,7 @@ Private Sub Image5_Click()
 End Sub
 
 Private Sub LevelRuler_Click()
-  Tools.瑙掑害杞�钩
+  Tools.角度转平
 End Sub
 
 Private Sub MakeSizes_Click()
@@ -196,70 +229,80 @@ Private Sub MakeSizes_Click()
 End Sub
 
 Private Sub MirrorLine_Click()
-  Tools.鍙傝€冪嚎闀滃儚
+  Tools.参考线镜像
 End Sub
 
 Private Sub SortCount_Click()
-  Tools.鎸夐潰绉�帓鍒� 50
+  Tools.按面积排列 50
 End Sub
 
 Private Sub SwapShape_Click()
-  Tools.浜ゆ崲瀵硅薄
+  Tools.交换对象
+End Sub
+
+
+
+Private Sub TESTPIC__MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+
+    TESTPIC.SpecialEffect = fmSpecialEffectSunken
+
 End Sub
+Private Sub UserForm_Click()
 
+End Sub
 
 Private Sub ZNQZ_Click()
-  Tools.鏅鸿兘缇ょ粍
+  Tools.智能群组
 End Sub
 
-Private Sub 璇诲彇鏂囨湰_Click()
+Private Sub 读取文本_Click()
   AutoCutLines.AutoCutLines
 End Sub
 
-Sub 璇诲彇姣忎竴琛屾暟鎹�()
+Sub 读取每一行数据()
     Dim txt As Object, t As Object, path As String
     Set txt = CreateObject("Scripting.FileSystemObject")
     
     Dim a
-    ' 鎸囧畾璺�緞
+    ' 指定路径
     path = "R:\Temp.txt"
-    ' 鈥�1鈥濊〃绀哄彧璇绘墦寮€锛屸€�2鈥濊〃绀哄啓鍏ワ紝True琛ㄧず鐩�爣鏂囦欢涓嶅瓨鍦ㄦ椂鏄�垱寤�
+    ' “1”表示只读打开，“2”表示写入，True表示目标文件不存在时是创建
     Set t = txt.OpenTextFile(path, 1, True)
     '--------------------------
-    ' 璇诲彇姣忎竴琛屽苟鎶婂唴瀹规樉绀哄嚭鏉�
+    ' 读取每一行并把内容显示出来
     Do While Not t.AtEndOfStream
 '        a = t.ReadLine
         a = a & t.ReadLine & vbNewLine
     TextBox1.Value = a
     Loop
     '--------------------------
-    ' 鎵撳紑鏂囨。锛屾敞鎰忊€渘otepad.exe 鈥濇渶鍚庢湁绌烘牸
+    ' 打开文档，注意“notepad.exe ”最后有空格
     Shell "notepad.exe " & path, vbNormalFocus
-    ' 閲婃斁鍙橀噺
+    ' 释放变量
     Set t = Nothing
     Set txt = Nothing
 End Sub
 
 
 
-Private Sub 瑁佸垏绾縚Click()
+Private Sub 裁切线_Click()
  AutoCutLines.AutoCutLines
  
 End Sub
 
 
-Private Sub 鎵嬪姩鎷肩増_Click()
+Private Sub 手动拼版_Click()
   ArrangeForm.Show 0
 End Sub
 
-Private Sub 绠楁硶璁＄畻_Click()
-  ChatGPT.璁＄畻琛屽垪
+Private Sub 算法计算_Click()
+  ChatGPT.计算行列
 End Sub
 
-Private Sub Z搴忔帓鍒梍Click()
-    ChatGPT.Z搴忔帓鍒�
+Private Sub Z序排列_Click()
+    ChatGPT.Z序排列
 End Sub
 
-Private Sub U搴忔帓鍒梍Click()
-  ChatGPT.姝ｅ紡U搴忔帓鍒�
+Private Sub U序排列_Click()
+  ChatGPT.正式U序排列
 End Sub

zerobase/ZCOPY.frm

@@ -6,7 +6,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ZCOPY
    ClientTop       =   330
    ClientWidth     =   4860
    OleObjectBlob   =   "ZCOPY.frx":0000
-   StartUpPosition =   1  '所有者中心
+   StartUpPosition =   1  'CenterOwner
 End
 Attribute VB_Name = "ZCOPY"
 Attribute VB_GlobalNameSpace = False
@@ -15,7 +15,7 @@ Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
 
 
-Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_square_hi", Shift, Button) = "exit" Then Exit Sub
     Set os = ActiveSelectionRange
     Set ss = os.Shapes
@@ -29,7 +29,7 @@ Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
 End Sub
 
 
-Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_square_wi", Shift, Button) = "exit" Then Exit Sub
     Set os = ActiveSelectionRange
     Set ss = os.Shapes
@@ -42,7 +42,7 @@ Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
     If ch_main_switch Then ActiveWindow.Activate
 End Sub
 
-Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_makesizes", Shift, Button) = "exit" Then Exit Sub
     Dim os As ShapeRange
     Dim s As Shape
@@ -84,36 +84,36 @@ Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
     Application.Refresh
 End Sub
 
-Private Sub btn_sizes_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_up", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "up", Shift
 End Sub
-Private Sub btn_sizes_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_dn", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "dn", Shift
 End Sub
-Private Sub btn_sizes_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_lf", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "lf", Shift
 End Sub
-Private Sub btn_sizes_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_ri", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "ri", Shift
 End Sub
 
-Private Sub btn_sizes_btw_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_btw_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_btw_up", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "upb", Shift
 End Sub
-Private Sub btn_sizes_btw_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_btw_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_btw_dn", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "dnb", Shift
 End Sub
-Private Sub btn_sizes_btw_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_btw_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_btw_lf", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "lfb", Shift
 End Sub
-Private Sub btn_sizes_btw_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub btn_sizes_btw_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
     If get_events("btn_sizes_btw_ri", Shift, Button) = "exit" Then Exit Sub
     make_sizes_sep "rib", Shift
 End Sub

zerobase/arrow.frm

@@ -0,0 +1,31 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} arrow 
+   Caption         =   "¼ýÍ·Ìæ»»¹¤¾ß    github.com/hongwenjun"
+   ClientHeight    =   2190
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   4770
+   OleObjectBlob   =   "arrow.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "arrow"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+Private Sub CommandButton1_Click()
+  arrowtool.SetArrow
+End Sub
+
+
+Private Sub CommandButton2_Click()
+  arrowtool.arrow_manual_tool
+End Sub
+
+Private Sub CommandButton3_Click()
+  arrowtool.arrow_Batch_repalce
+End Sub
+
+Private Sub CommandButton4_Click()
+  arrowtool.turn_over
+End Sub

zerobase/arrowtool.bas

@@ -0,0 +1,107 @@
+Attribute VB_Name = "arrowtool"
+Public Sub SetArrow()
+  Dim s As Shape
+  Set s = ActiveShape
+  s.name = "arrow"
+End Sub
+
+Public Sub turn_over()
+  Dim sr As ShapeRange, s As Shape
+  Set sr = ActiveSelectionRange
+  
+  For Each s In sr
+    s.RotationAngle = s.RotationAngle + 180
+  Next s
+End Sub
+
+
+Sub arrow_Batch_repalce()
+  Dim old As Shape, src As Shape, arrow_set As ShapeRange
+  Dim nr As NodeRange
+  Dim x1 As Double, y1 As Double
+  Dim x2 As Double, y2 As Double
+  
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  
+  For Each old In sr
+    Set nr = old.DisplayCurve.Nodes.All
+    x1 = nr(1).PositionX
+    y1 = nr(1).PositionY
+    x2 = nr(2).PositionX
+    y2 = nr(2).PositionY
+    Angle = lineangle(x1, y1, x2, y2)
+    
+    Set src = old.Duplicate(0, 0)
+    src.Rotate -Angle
+    
+    Set arrow_set = ActivePage.Shapes.FindShapes(Query:="@name ='arrow'")
+    
+    arrow_repalce arrow_set(1), src, Angle
+    src.Delete: old.Delete
+  Next old
+End Sub
+
+
+Sub arrow_repalce(arrow As Shape, src As Shape, ByVal Angle As Double)
+  ActiveDocument.Unit = cdrMillimeter
+  Set s = arrow.Duplicate(0, 0)
+  s.name = "new_arrow"
+  s.SizeWidth = src.SizeWidth
+  s.SizeHeight = src.SizeHeight
+  s.RotationAngle = Angle
+  s.CenterX = src.CenterX: s.CenterY = src.CenterY
+  
+ ' If Angle > 180 Then s.RotationAngle = s.RotationAngle + 180
+End Sub
+
+
+ Sub arrow_manual_tool()
+ Dim old As Shape, src As Shape, arrow_set As ShapeRange
+ Dim nr As NodeRange
+ Dim x1 As Double, y1 As Double
+ Dim x2 As Double, y2 As Double
+ Set nr = ActiveShape.Curve.Selection
+ Set old = ActiveShape
+ x1 = nr(1).PositionX
+ y1 = nr(1).PositionY
+ x2 = nr(2).PositionX
+ y2 = nr(2).PositionY
+ Angle = lineangle(x1, y1, x2, y2)
+
+ Set src = old.Duplicate(0, 0)
+' MsgBox Angle
+ src.Rotate -Angle
+ 
+ Set arrow_set = ActivePage.Shapes.FindShapes(Query:="@name ='arrow'")
+ 
+ arrow_repalce arrow_set(1), src, Angle
+ 
+ src.Delete: old.Delete
+End Sub
+
+
+' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
+' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
+' VB中用atn(), 返回值是弧度，需要 乘以 PI /180
+Private Function old_lineangle(x1, y1, x2, y2) As Double
+  pi = 4 * VBA.Atn(1) ' 计算圆周率
+  If x2 = x1 Then
+    lineangle = 90: Exit Function
+  End If
+  lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
+End Function
+
+Private Function lineangle(x1, y1, x2, y2) As Double
+  If x2 = x1 Then lineangle = 90: Exit Function
+  pi = 4 * VBA.Atn(1)
+
+  k = (y2 - y1) / (x2 - x1)
+  Angle = VBA.Atn(k) * 180 / pi
+  
+  If k >= 0 Then
+    lineangle = Angle
+  Else
+    lineangle = Angle + 180
+  End If
+End Function

zerobase/frmEditPowerClip.frm

@@ -0,0 +1,258 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmEditPowerClip 
+   Caption         =   "容器便捷调整"
+   ClientHeight    =   3090
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   3510
+   OleObjectBlob   =   "frmEditPowerClip.frx":0000
+   ShowModal       =   0   'False
+   StartUpPosition =   2  'CenterScreen
+End
+Attribute VB_Name = "frmEditPowerClip"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+Option Explicit
+Dim xzbj As Boolean
+Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call commdanliu(Lab001)
+    Call commdanliu(Lab002)
+    Call commdanliu(Lab003)
+    Call commdanliu(Lab004)
+    Call commdanliu(Lab005)
+    Call commdanliu(Lab006)
+    Call commdanliu(Lab007)
+    Call commdanliu(Lab008)
+End Sub
+Private Sub Lab001_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab001)
+End Sub
+Private Sub Lab002_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab002)
+End Sub
+Private Sub Lab003_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab003)
+End Sub
+Private Sub Lab004_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab004)
+End Sub
+Private Sub Lab005_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab005)
+End Sub
+Private Sub Lab006_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab006)
+End Sub
+Private Sub Lab007_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab007)
+End Sub
+Private Sub Lab008_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    Call anliumove(Lab008)
+End Sub
+Private Sub Lab001_Click()
+    BeginOpt "提取裁切框内容"
+    Container.Extractall (IIf(CheckBox1.Value, True, False))
+    EndOpt
+End Sub
+Private Sub Lab002_Click()
+    BeginOpt "清空裁切框"
+    Container.Emptyall
+    EndOpt
+End Sub
+Private Sub Lab003_Click()
+    BeginOpt "按比例调整内容"
+        Container.Bilingtznr
+    EndOpt
+End Sub
+Private Sub Lab004_Click()
+    BeginOpt "按比例填充"
+        Container.Bilintianchun
+    EndOpt
+End Sub
+Private Sub Lab005_Click()
+    BeginOpt "延展填充"
+    Container.Qiangzhitianmian
+    EndOpt
+End Sub
+Private Sub Lab006_Click()
+    BeginOpt "锁定精确裁剪"
+    Container.Lockall True
+    EndOpt
+End Sub
+Private Sub Lab007_Click()
+    BeginOpt "解锁精确裁剪"
+        Container.Lockall False
+    EndOpt
+End Sub
+Private Sub Lab008_Click()
+    BeginOpt "内容居中"
+    Container.CenterToPC
+    EndOpt
+End Sub
+Private Sub txtNilai_Change()
+   Dim i As Integer
+   Dim s As String
+   With txtNilai
+      For i = 1 To VBA.Len(.text)
+           s = VBA.Mid(.text, i, 1)
+            Select Case s
+              Case ".", "0" To "9"
+              Case Else
+               .text = VBA.Replace(.text, s, "")
+            End Select
+         Next
+     End With
+End Sub
+Private Sub SpinButton1_SpinUp()
+    txtNilai.text = VBA.CStr(txtNilai.Value + 1)
+End Sub
+Private Sub SpinButton1_SpinDown()
+    If txtNilai.Value <= 1 Then Exit Sub
+    txtNilai.text = VBA.CStr(txtNilai.Value - 1)
+End Sub
+Private Sub UserForm_Initialize()
+    If Strbjini = "" Then Strbjini = VBA.GetSetting(xylAppName, xylSection, "Apppath"): BJAppLJ = Strbjini & "\DaTa\dat\"
+    If GetmdbValue(BJAppLJ & "xylTools.ini", "Form", "rqtzFr_l", "") <> "" Then
+        Me.StartUpPosition = 0
+        Me.Left = GetmdbValue(BJAppLJ & "xylTools.ini", "Form", "rqtzFr_l", "")
+        Me.Top = GetmdbValue(BJAppLJ & "xylTools.ini", "Form", "rqtzFr_t", "")
+    End If
+    Call AddStroyComandBox(Me.cboUnit, "毫米,厘米,英寸,像素")
+    Me.cboUnit.text = GetmdbValue(BJAppLJ & "xylTools.ini", "Rongqibjtz", "单位", "毫米")
+    xzbj = False
+    cboUnit.Enabled = False
+    txtNilai.Enabled = False
+    SpinButton1.Enabled = False
+    spnPositionX.Enabled = False
+    spnPositionY.Enabled = False
+    spnZoom.Enabled = False
+    spnRotate.Enabled = False
+    Me.Tis.BackColor = RGB(0, 147, 222)
+    Me.Tis.ForeColor = RGB(255, 255, 255)
+    Me.Tis.Caption = "  可以选择一个容器对象后操作！"
+End Sub
+Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
+    SetmdbValue BJAppLJ & "xylTools.ini", "Form", "rqtzFr_l", frmEditPowerClip.Left
+    SetmdbValue BJAppLJ & "xylTools.ini", "Form", "rqtzFr_t", frmEditPowerClip.Top
+    SetmdbValue BJAppLJ & "xylTools.ini", "Rongqibjtz", "单位", Me.cboUnit.text
+End Sub
+Sub getShapeByUser()
+re:
+    Dim doc As Document, retval As Long
+    Dim x As Double, Y As Double, Shift As Long
+    Dim o_seleksi As ShapeRange
+    Set doc = ActiveDocument
+    doc.ReferencePoint = cdrCenter
+    retval = doc.GetUserClick(x, Y, Shift, 10, True, cdrCursorPick)
+    doc.ActivePage.SelectShapesAtPoint x, Y, True
+    Dim SC As Shape
+    Dim sp As PowerClip
+    Set SC = ActiveShape
+    If SC Is Nothing Then xzbj = False: Me.Show: Exit Sub
+    Set sp = SC.PowerClip
+    If sp Is Nothing Then
+        AutoMsgbox "选择对象不是容器；" & vbCrLf & "可以重新选择，或点击空白处退出！", vbCritical, "新印联提示": GoTo re
+    Else
+        If sp.Shapes.Count = 0 Then
+            AutoMsgbox "容器为空；" & vbCrLf & "可以重新选择，或点击空白处退出！", vbCritical, "新印联提示": GoTo re
+        End If
+    End If
+    xzbj = True
+End Sub
+Sub doAction(ByVal doAction As String, Optional ByVal bolUp As Boolean = False)
+    doAction = VBA.LCase(doAction)
+    ActiveDocument.ReferencePoint = cdrCenter
+    If cboUnit.ListIndex = 0 Then
+        ActiveDocument.Unit = cdrMillimeter
+    ElseIf cboUnit.ListIndex = 1 Then
+        ActiveDocument.Unit = cdrCentimeter
+    ElseIf cboUnit.ListIndex = 2 Then
+        ActiveDocument.Unit = cdrInch
+    ElseIf cboUnit.ListIndex = 3 Then
+        ActiveDocument.Unit = cdrPixel
+    End If '
+    Dim setNilai As Double
+    setNilai = CDbl(txtNilai.Value)
+    If bolUp = False Then setNilai = -setNilai
+    Dim s As Shape, sr As ShapeRange
+    Set sr = ActiveSelectionRange
+    For Each s In sr
+        Call checkPowerClip(s, doAction, setNilai, bolUp)
+    Next s
+End Sub
+Private Function checkPowerClip(s As Shape, ByVal doAction As String, ByVal setNilai As Double, ByVal bolUp As Boolean)
+    Dim pwc As PowerClip, sr As ShapeRange
+    If Not s.PowerClip Is Nothing Then
+        Set pwc = s.PowerClip
+        Set sr = pwc.Shapes.FindShapes
+        If doAction = "position_x" Then
+            sr.PositionX = sr.PositionX + setNilai
+        ElseIf doAction = "position_y" Then
+            sr.PositionY = sr.PositionY + setNilai
+        ElseIf doAction = "rotate" Then
+            sr.Rotate setNilai
+        ElseIf doAction = "zoom" Then
+            sr.Stretch sr.SizeWidth / (sr.SizeWidth + setNilai)
+        End If
+    End If
+End Function
+Private Sub cmdPickObject_Click()
+    Me.Hide
+    Call getShapeByUser
+    If xzbj = True Then
+       Me.Tis.Caption = "  可以重新选择一个容器操作！"
+       If cmdPickObject.ControlTipText = "选择容器" Then
+          cboUnit.Enabled = True
+          txtNilai.Enabled = True
+          SpinButton1.Enabled = True
+          spnPositionX.Enabled = True
+          spnPositionY.Enabled = True
+          spnZoom.Enabled = True
+          spnRotate.Enabled = True
+       End If
+       Me.Show
+       cmdPickObject.ControlTipText = "重新选择一个容器"
+    End If
+End Sub
+Private Sub spnPositionX_SpinDown()
+    Call doAction("position_x", False)
+End Sub
+Private Sub spnPositionX_SpinUp()
+    Call doAction("position_x", True)
+End Sub
+Private Sub spnPositionY_SpinDown()
+    Call doAction("position_y", False)
+End Sub
+Private Sub spnPositionY_SpinUp()
+    Call doAction("position_y", True)
+End Sub
+Private Sub spnRotate_SpinUp()
+    Call doAction("rotate", False)
+End Sub
+Private Sub spnRotate_SpinDown()
+    Call doAction("rotate", True)
+End Sub
+Private Sub spnZoom_SpinUp()
+    Call doAction("zoom", False)
+End Sub
+Private Sub spnZoom_SpinDown()
+    Call doAction("zoom", True)
+End Sub
+Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+     cmdPickObject.SpecialEffect = fmSpecialEffectEtched
+End Sub
+Private Sub cmdPickObject_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+   cmdPickObject.SpecialEffect = fmSpecialEffectSunken
+End Sub
+Private Sub cmdPickObject_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    cmdPickObject.SpecialEffect = fmSpecialEffectRaised
+End Sub
+Private Sub cmdPickObject_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+    If Button = 0 Then
+        cmdPickObject.SpecialEffect = fmSpecialEffectRaised
+    ElseIf Button = 1 Then
+        cmdPickObject.SpecialEffect = fmSpecialEffectSunken
+    End If
+End Sub

zerobase/frmSelectSame.frm

@@ -0,0 +1,708 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmSelectSame 
+   Caption         =   "相似选择-魔改版 蘭雅"
+   ClientHeight    =   5775
+   ClientLeft      =   495
+   ClientTop       =   5895
+   ClientWidth     =   2625
+   OleObjectBlob   =   "frmSelectSame.frx":0000
+   ShowModal       =   0   'False
+End
+Attribute VB_Name = "frmSelectSame"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+Option Explicit
+'需要显式声明所有变量。 这可以防止无意中使用缓慢的“Variant”类型变量，这些变量在特定类型未知时使用。
+'Requires explicit declaration of all variables. This protects against inadvertent use of the slow 'Variant' type variables which are used when the specific type is unknown.
+
+Public ssreg As ShapeRange
+
+Private Const TOOLNAME As String = "VBA_SelectSame"
+Private Const SECTION As String = "Options"
+
+Private Sub btnSelect_Click()
+    If 0 = ActiveSelectionRange.Count Then Exit Sub
+    On Error GoTo ErrorHandler
+    
+    Dim fLeft As Double, fTop As Double
+    fLeft = frmSelectSame.Left
+    fTop = frmSelectSame.Top
+    SaveSetting "SelectSame", "Preferences", "form_left", fLeft
+    SaveSetting "SelectSame", "Preferences", "form_top", fTop
+    
+    '// 区域范围选择，需要关闭刷新优化
+    If OptBt.Value = False Then
+      API.BeginOpt
+    Else
+      add_ssreg
+    End If
+    
+    If (chkFill = False And chkOutline = False And chkOutlineColor = False And _
+      chkOutlineLength = False And chkSize = False And chkWHratio = False And _
+      chkType = False And chkNodes = False And chkSegments = False And _
+      chkPaths = False And chkFontName = False And chkFontSize = False And chkShapeName = False) Then
+        MsgBox "请至少选择一个选项", vbCritical, "Select Same"
+        GoTo ErrorHandler
+    End If
+
+
+'// "ME"是一个VBA保留字，返回对当前代码所在窗体（或类模块）的引用。 chk... 函数返回同名复选按钮的当前值。
+'// "ME" is a VBA reserved word, returning a reference to the form (or class module) in which the current code is located.
+'//  The chk... functions return the current Value of the check buttons of the same name.
+    With Me
+      .SelectAllSimilar .chkFill, .chkOutline, .chkOutlineColor, .chkOutlineLength, _
+      .chkSize, .chkWHratio, .chkType, .chkNodes, .chkSegments, .chkPaths, _
+      .OptDoc, .Optpage, .Optlayer, .chkInGroups, .chkColorMark, .chkIndiv, _
+      .chkFontName, .chkFontSize, .chkShapeName
+    End With
+    
+    API.EndOpt
+    
+Exit Sub
+ErrorHandler:
+  Application.Optimization = False
+End Sub
+
+Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
+                    Optional CheckOutline As Boolean = True, _
+                    Optional CheckOutlineColor As Boolean = True, _
+                    Optional CheckOutlineLength As Boolean = True, _
+                    Optional CheckSize As Boolean = False, _
+                    Optional CheckWHratio As Boolean = False, _
+                    Optional CheckType As Boolean = True, _
+                    Optional CountNodes As Boolean = False, _
+                    Optional CountSegments As Boolean = False, _
+                    Optional CountPaths As Boolean = False, _
+                    Optional WithinDoc As Boolean = False, _
+                    Optional WithinPage As Boolean = True, _
+                    Optional WithinLayer As Boolean = False, _
+                    Optional WithinGroups As Boolean = True, _
+                    Optional CheckColorMark As Boolean = False, _
+                    Optional CheckIndiv As Boolean = True, _
+                    Optional CheckFontName As Boolean = False, _
+                    Optional CheckFontSize As Boolean = False, _
+                    Optional CheckShapeName As Boolean = False)
+                    
+    'Object variables.              Reference to:
+    Dim shpsSelected As Shapes          'selected shapes,
+    Dim shpsToTest As Shapes            'full set of shapes to be tested,  ' 待测形状全部集合
+    Dim 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 shr As ShapeRange, sr As New ShapeRange
+    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. 将文档中当前选中的范围作为源对象
+    
+    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. 建立源对象集合
+           clnModelShapes.Add shpModel
+        Next
+        
+
+        '// 魔改分支 字体-字号-标记名
+        If CheckFontName Or CheckFontSize Or CheckShapeName Then
+          Set fsn = shr(1)
+        End If
+
+        '===================================
+        ' TurnOptimizations cdrOptimizationOn
+        '===================================
+       
+        If WithinPage Then
+
+          If OptBt.Value = True Then
+            Set shpsToTest = ssreg.Shapes
+            OptBt.Value = 0
+            API.BeginOpt
+          Else
+            Set shpsToTest = ActivePage.Shapes
+          End If
+                                            'Ensure that "Edit across layers"
+                                            'is ON. Otherwise, selecting
+'            Set oScript = CorelScript       'across layers, followed by
+'            oScript.SetMultiLayer True      'grouping, can flatten all
+'            Set oScript = Nothing           'layers into one. 选中表示将对当前页面的所有对象与源对象进行匹配，否则只匹配当前图层的对象
+ 
+            'Replace the above with this line, CoreScript is not longer support X7+
+            ActiveDocument.EditAcrossLayers = True
+        End If
+        If WithinLayer Then
+            Set shpsToTest = ActivePage.ActiveLayer.Shapes
+        End If
+        
+        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 '各页面依次查找，相应的对象加入到待比较范围
+                
+            Next i
+            Set shpsToTest = docsr.Shapes
+'            MsgBox "共有待比较对象 " & shpsToTest.Count & " 个"
+            Label13.Caption = "共有待比较对象 " & shpsToTest.Count & " 个"
+            'p1.Activate
+        End If
+        
+        If WithinGroups Then                'Check through flattened list.
+            Set clnSubShapes = FlatShapeList(shpsToTest)
+            '=======
+            For Each shpToMatch In clnSubShapes
+                If Not shpToMatch.Selected Then 'If the shape is not yet selected,
+                
+                   '====================     'check the models for a match.
+                    For Each shpModel In clnModelShapes
+                        If ShapesMatch(shpToMatch, shpModel, CheckFill, _
+                                CheckOutline, CheckOutlineColor, CheckOutlineLength, CheckSize, CheckWHratio, _
+                                CheckType, CountNodes, CountSegments, CountPaths, CheckIndiv) Then
+                            'shpToMatch.AddToSelection
+                            sr.Add shpToMatch
+                            Exit For        'If a match has now been found,
+                        End If              'we can skip any remaining models.
+                    Next
+                   '=====================
+                   
+                End If
+            Next
+            '=======
+        Else                                'Check through top-level list.
+            For Each shpToMatch In shpsToTest
+                If Not shpToMatch.Selected Then 'If the shape is not yet selected,
+                                            'check the models for a match.
+                    For Each shpModel In clnModelShapes
+                        If ShapesMatch(shpToMatch, shpModel, CheckFill, _
+                                CheckOutline, CheckOutlineColor, CheckOutlineLength, CheckSize, CheckWHratio, _
+                                CheckType, CountNodes, CountSegments, CountPaths, CheckIndiv) Then
+                               'shpToMatch.AddToSelection
+                            sr.Add shpToMatch
+                            Exit For        'If a match has now been found,
+                        End If              'we can skip any remaining models.
+                    Next
+                    
+                End If
+            Next
+        End If
+            
+        '===================================
+       ' TurnOptimizations cdrOptimizationOff
+        'CorelScript.RedrawScreen
+        '===================================
+        'sr.Add ActiveDocument.Selection
+        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"
+          If CheckShapeName Then ShapesMatch_Font_Name fsn, sr, "ShapeName"
+        End If
+        
+       sr.CreateSelection
+        '// 显示找到对象
+        Label13.Caption = "共找到 " & sr.Count & " 个对象"
+    End If
+    
+    Set clnModelShapes = Nothing               'Release the memory allocated
+    Set shpsToTest = Nothing
+    Exit Sub
+NothingSelected:
+End Sub
+
+'// 添加区域选择分支
+Private Function add_ssreg()
+    Dim ssr As ShapeRange, shr As ShapeRange
+    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
+    Dim Shift As Long
+    Dim b As Boolean
+    Set shr = ActiveSelectionRange
+    b = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
+    If Not b Then
+      Set ssreg = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, True).Shapes.All
+    End If
+    ActiveDocument.ClearSelection
+    shr.CreateSelection
+End Function
+
+'// 魔改分支 字体-字号-标记名  检查匹配
+Private Function ShapesMatch_Font_Name(ByVal fsn As Shape, sr As ShapeRange, Check_Case As String)
+  Dim xz As String, sh_name As String, strFontName As String
+  Dim FontSize As Double
+  Dim srText As ShapeRange
+  Set srText = sr.Shapes.FindShapes(Type:=cdrTextShape)
+      
+  Select Case Check_Case
+  Case "FontName"
+    If fsn.Type = cdrTextShape Then
+      strFontName = fsn.text.Story.Font
+      Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and @com.text.story.font = '" & strFontName & "'")
+    End If
+    
+  Case "FontSize"
+    If fsn.Type = cdrTextShape Then
+      FontSize = fsn.text.Story.size
+      Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and (@com.text.story.size - " & FontSize & ").abs() < 0.1 ")
+    End If
+    
+  Case "ShapeName"
+    sh_name = fsn.name
+      Set sr = sr.Shapes.FindShapes(Query:="@name ='" & sh_name & "'")
+  End Select
+End Function
+
+
+Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
+                    Optional CheckFill As Boolean = True, _
+                    Optional CheckOutline As Boolean = True, _
+                    Optional CheckOutlineColor As Boolean = True, _
+                    Optional CheckOutlineLength As Boolean = True, _
+                    Optional CheckSize As Boolean = False, _
+                    Optional CheckWHratio As Boolean = False, _
+                    Optional CheckType As Boolean = True, _
+                    Optional CountNodes As Boolean = False, _
+                    Optional CountSegments As Boolean = False, _
+                    Optional CountPaths As Boolean = False, _
+                    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 ToleranceLength As Double   '线长允许波动
+    ToleranceLength = Me.TextBox2 / 100 '长度允许波动,以百分比为单位
+    
+    Dim ToleranceNodesCount As Long  '节点数量允许波动,以 点 单位
+    ToleranceNodesCount = Me.TextBox3 '节点数量允许波动,以 点 单位
+    
+    Dim ToleranceSubPathsCount As Long  '子路径 子线段 允许波动,以 条 为单位
+    ToleranceSubPathsCount = Me.TextBox4 '子路径 子线段 允许波动,以 条 为单位
+    
+    Dim ToleranceWHratio As Double  '长宽比 允许波动,以 百分比 为单位
+    ToleranceWHratio = Me.TextBox5  '长宽比 允许波动,以 百分比 为单位
+    
+    Dim ToleranceSegmentsCount As Long  '线段数 允许波动,以 个 为单位
+    ToleranceSegmentsCount = Me.TextBox6 '线段数 允许波动,以 个 为单位
+        
+    'Object Variables.        'Reference to:
+    Dim clrModel As Color           'color features of model shape,
+    Dim clrShape As Color           'color features of shape to be tested
+    Dim fillModel As Fill           'fill style of model shape,
+    Dim outlnModel As Outline       'outline style of model shape,
+    Dim crvModel As Curve           'Bezier curve of model shape,
+    Dim crvShape As Curve           'Bezier curve of shape to be tested,
+    Dim fntModel As StructFontProperties  'font properties of model text shape,
+    Dim trgModel As text            'general text properties of model shape.
+    Dim spath As SubPath, opath As SubPath
+    Dim j As Integer
+    
+    'Simple Variables.              Storage of:
+    Dim dblWidth As Double              'width of a shape,
+    Dim dblHeight As Double             'height of a shape,
+    Dim lngShapeType As cdrShapeType    'code for type of shape to be tested,
+    Dim lngModelType As cdrShapeType    'code for the type of a model shape,
+    Dim lngType As Long                 'code for the type of a fill, color,
+                                        'or outline.
+                                        
+    
+                                        'Does the SHAPE match the MODEL ?
+                                        'Exit immediately on any mismatch.
+    With shpShape
+        lngShapeType = .Type            'Same basic TYPE of shape ?
+        lngModelType = shpModel.Type
+        
+        If CheckType Then If lngShapeType <> lngModelType Then GoTo NoMatch
+                                        'A GROUP ? delegate to GroupsMatch()
+'        If lngShapeType = cdrGroupShape Then
+'            ShapesMatch = GroupsMatch(shpShape, shpModel, CheckSize, _
+'                                CountNodes, CountPaths)
+'            Exit Function
+'        End If
+
+                                        'Does SIZE count ? Is so, are the
+        If CheckSize Then               'size differences significant ?
+            dblWidth = shpModel.SizeWidth
+            If Abs(.SizeWidth - dblWidth) > (dblWidth * _
+                 ToleranceSize) Then GoTo NoMatch
+            dblHeight = shpModel.SizeHeight
+            If Abs(.SizeHeight - dblHeight) > (dblHeight * _
+                ToleranceSize) Then GoTo NoMatch
+        End If
+        
+        If CheckWHratio Then               'size width and height ratio differences significant ?
+            dblWidth = shpModel.SizeWidth
+            dblHeight = shpModel.SizeHeight
+            If Abs(.SizeHeight / .SizeWidth - dblHeight / dblWidth) > (dblHeight / dblWidth * ToleranceWHratio) Then GoTo NoMatch
+        End If
+        
+
+            If CountNodes Or CountPaths Or CheckOutlineLength Or CountSegments Then
+                                        'Only Curves can match ...
+                If lngShapeType <> cdrCurveShape Then GoTo NoMatch
+                
+                Set crvShape = .Curve
+                Set crvModel = shpModel.Curve
+                
+                '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
+                     
+                     'Next j
+                
+                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
+                        'MsgBox "subpaths1: " & crvShape.SubPaths.Count & "subpaths2: " & crvModel.SubPaths.Count
+                    Else
+                        If Abs(crvShape.SubPathCount - crvModel.SubPathCount) > ToleranceSubPathsCount Then GoTo NoMatch
+                    End If 'GDG #############################################################
+                    
+                End If
+                
+                
+                 
+                 
+                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
+                    Else
+                        If Abs(crvShape.NodeCount - crvModel.NodeCount) > ToleranceNodesCount Then GoTo NoMatch
+                    End If 'GDG #############################################################
+                    
+                End If
+                
+                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
+                    Else
+                        If Abs(crvShape.SegmentCount - crvModel.SegmentCount) > ToleranceSegmentsCount Then GoTo NoMatch
+                    End If 'GDG #############################################################
+                    
+                End If
+        
+                
+                
+                If CheckOutlineLength Then      'Do the curve length match ?
+                
+                    If VersionMajor > 12 Then 'GDG ##########################################
+                        If Abs(crvShape.Length - crvModel.Length) > crvModel.Length * ToleranceLength Then GoTo NoMatch
+                        'MsgBox "subpaths1: " & crvShape.SubPaths.Count & "subpaths2: " & crvModel.SubPaths.Count
+                    Else
+                        If Abs(crvShape.Length - crvModel.Length) > crvModel.Length * ToleranceLength Then GoTo NoMatch
+                    End If 'GDG #############################################################
+                    
+                End If
+            End If
+        If CheckFill Then
+            Set fillModel = shpModel.Fill
+            With .Fill                  'Is the FILL type the same ?
+                lngType = .Type
+                If lngType <> shpModel.Fill.Type Then GoTo NoMatch
+                If lngType = cdrUniformFill Then
+'Does the uniform fill match ?
+                    If VersionMajor > 12 Then 'GDG ##########################################
+                        'GDG ##########################################
+                        Dim col1 As New Color
+                        col1.CopyAssign .UniformColor
+                        Dim col2 As New Color
+                        col2.CopyAssign shpModel.Fill.UniformColor
+                        'GDG ##########################################
+                        If col1.IsSame(col2) = False Then GoTo NoMatch
+                    Else
+                        Set clrModel = fillModel.UniformColor
+                        lngType = .UniformColor.Type
+                        If lngType <> clrModel.Type Then GoTo NoMatch
+                        If .UniformColor.name(True) <> clrModel.name(True) Then GoTo NoMatch
+                    End If  'GDG #############################################################
+                End If
+            End With
+        End If
+        
+        
+        
+        If CheckOutline Then            '(Groups have no outline)
+            If lngShapeType <> cdrGroupShape Then
+                Set outlnModel = shpModel.Outline
+                If Not outlnModel Is Nothing Then
+                    With .Outline
+                        lngType = .Type
+                        If lngType <> outlnModel.Type Then GoTo NoMatch
+                                                
+                        If lngType > 0 Then     'Does the shape have an OUTLINE ?
+                                                'Same LINE WIDTH ?
+                            If .Width <> outlnModel.Width Then GoTo NoMatch
+                                                'Matching LINE COLOR ?
+'                            Set clrShape = .Color
+'                            lngType = clrShape.Type
+'                            Set clrModel = outlnModel.Color
+'                            If lngType <> clrModel.Type Then GoTo NoMatch
+'                            If clrShape.Name(True) <> clrModel.Name(True) Then GoTo NoMatch
+                        End If
+                    End With
+                End If
+            End If
+        End If
+        
+        
+        If CheckOutlineColor Then            '(Groups have no outline)
+            If lngShapeType <> cdrGroupShape Then
+ 
+               
+                Set outlnModel = shpModel.Outline
+                If Not outlnModel Is Nothing Then
+                    
+                    With .Outline
+                        lngType = .Type
+                        If lngType <> outlnModel.Type Then GoTo NoMatch
+                                                
+                        If lngType > 0 Then     'Does the shape have an OUTLINE ?
+                                                'Matching LINE COLOR ?
+                            
+                            If VersionMajor > 12 Then 'GDG ##########################################
+                                'GDG ##########################################
+                                Dim col3 As New Color
+                                col3.CopyAssign .Color
+                                Dim col4 As New Color
+                                col4.CopyAssign shpModel.Outline.Color
+                                'GDG ##########################################
+                                If col3.IsSame(col4) = False Then GoTo NoMatch
+                            Else
+                                Set clrShape = .Color
+                                lngType = clrShape.Type
+                                Set clrModel = outlnModel.Color
+                                If lngType <> clrModel.Type Then GoTo NoMatch
+                                If clrShape.name(True) <> clrModel.name(True) _
+                                    Then GoTo NoMatch
+                            End If
+                        End If
+                    End With
+                End If
+            End If
+        End If
+        
+    End With
+    
+    ShapesMatch = True
+    Exit Function
+    
+NoMatch:
+    ShapesMatch = False
+    
+NoMatchExit:
+    ShapesMatch = False
+    Exit Function
+End Function
+
+Private Function GroupsMatch(Group As Shape, GroupModel As Shape, _
+                    Optional CheckFill As Boolean = True, _
+                    Optional CheckOutline As Boolean = True, _
+                    Optional CheckOutlineColor As Boolean = True, _
+                    Optional CheckOutlineLength As Boolean = True, _
+                    Optional CheckSize As Boolean = False, _
+                    Optional CheckType As Boolean = True, _
+                    Optional CountNodes As Boolean = False, _
+                    Optional CountPaths As Boolean = False) As Boolean
+    
+    'Object Variables.              Reference to:
+    Dim shpsModels As Shapes            'shapes in the pre-selected group,
+    Dim shpsInGroup As Shapes           'shapes in the group to be tested,
+    Dim shpModel As Shape               'a shape in the pre-selected group,
+    Dim shpInGroup As Shape             'a shape in the group to be tested.
+    
+    'Simple Variables               Storage of:
+    Dim lngInGroup As Long              'number of shapes in a group,
+    Dim i As Long                       'a numeric index to a
+                                        'particular sub-group.
+                                        
+    'On Error GoTo NoMatch              'Shape & model must be groups.
+    Set shpsModels = GroupModel.Shapes
+    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
+        
+    For i = 1 To lngInGroup             'Try to Match all sub-shapes,
+        Set shpInGroup = shpsInGroup(i) 'and GroupsMatch all sub-groups.
+        Set shpModel = shpsModels(i)
+        
+        If shpModel.Type <> cdrGroupShape Then
+            If Not ShapesMatch(shpInGroup, shpModel, _
+                            CheckSize, CountNodes) Then GoTo NoMatch
+        Else
+            If Not GroupsMatch(shpInGroup, shpModel, _
+                            CheckSize, CountNodes) Then GoTo NoMatch
+        End If
+    Next i
+    
+    GroupsMatch = True
+    Exit Function
+NoMatch:
+    GroupsMatch = False
+End Function
+
+
+Private Function FlatShapeList(TopLevelShapes As Shapes) As Collection
+    
+    'Object Variables.          Reference to:
+    Dim shpTopLevel As Shape        'a top-level shape,
+    Dim shpInGroup As Shape         'a shape inside a group,
+    Dim clnAllShapes As Collection  'our list of all members and
+                                    'descendants of TopLevelShapes.
+                                       
+    If TopLevelShapes.Count Then
+        Set clnAllShapes = New Collection
+        For Each shpTopLevel In TopLevelShapes
+                                    'Add shape to list, keyed under
+                                    'a string version of its unique ID
+             clnAllShapes.Add shpTopLevel
+                                    'If the shape is a group, then
+                                    'also gather all its descendants
+                                    'and add them to the list.
+            If shpTopLevel.Type = cdrGroupShape Then
+                For Each shpInGroup In ShapesInGroup(shpTopLevel)
+               clnAllShapes.Add shpInGroup
+                Next
+            End If
+        Next
+        Set FlatShapeList = clnAllShapes  'Return the assembled collection.
+    Else
+        Set FlatShapeList = Nothing
+    End If
+End Function
+
+Private Function ShapesInGroup(GroupShape As Shape) As Collection
+
+    'Object Variables.              Reference to:
+    Dim shpsInGroup As Shapes           'the set of shapes inside a group,
+    Dim shpInGroup As Shape             'a particular shape in a group,
+    Dim shpNested As Shape              'a shape inside a sub-group,
+    Dim clnShapeList As Collection      'our list of all nested shapes.
+    
+    If GroupShape.Type = cdrGroupShape Then
+        Set shpsInGroup = GroupShape.Shapes 'Get a reference to the
+                                            'shapes in this group.
+        Set clnShapeList = New Collection
+        For Each shpInGroup In shpsInGroup
+            clnShapeList.Add shpInGroup     'Add all shapes in the group to
+                                            'our main collection.
+            If shpInGroup.Type = cdrGroupShape Then
+                                            'Recurse to get nested shapes.
+                For Each shpNested In ShapesInGroup(shpInGroup)
+                    clnShapeList.Add shpNested
+                Next
+            End If
+        Next
+        Set ShapesInGroup = clnShapeList    'Return the assembled collection.
+    Else
+        Set ShapesInGroup = Nothing         'Release the memory if the
+    End If                                  'collection is not needed
+End Function
+
+Private Sub UserForm_Activate()
+    Const YES As String = "True"
+    Const NO As String = "False"
+
+    OptDoc = GetSetting(TOOLNAME, SECTION, "InDoc", NO)
+    Optlayer = GetSetting(TOOLNAME, SECTION, "InLayer", NO)
+    Optpage = GetSetting(TOOLNAME, SECTION, "InPage", YES)
+    
+    chkColorMark = GetSetting(TOOLNAME, SECTION, "ColorMark", YES)
+    chkFill = GetSetting(TOOLNAME, SECTION, "Fill", YES)
+    chkInGroups = GetSetting(TOOLNAME, SECTION, "InGroups", YES)
+    chkNodes = GetSetting(TOOLNAME, SECTION, "Nodes", NO)
+    chkSegments = GetSetting(TOOLNAME, SECTION, "Segments", NO)
+    chkOutline = GetSetting(TOOLNAME, SECTION, "Outline", YES)
+    chkOutlineColor = GetSetting(TOOLNAME, SECTION, "OutlineColor", NO)
+    chkOutlineLength = GetSetting(TOOLNAME, SECTION, "OutlineLength", YES)
+    chkPaths = GetSetting(TOOLNAME, SECTION, "Paths", NO)
+    chkSize = GetSetting(TOOLNAME, SECTION, "Size", NO)
+    chkWHratio = GetSetting(TOOLNAME, SECTION, "WHratio", NO)
+    chkType = GetSetting(TOOLNAME, SECTION, "Type", YES)
+    chkIndiv = GetSetting(TOOLNAME, SECTION, "Indiv", NO)
+    chkColorMark = GetSetting(TOOLNAME, SECTION, "ColorMark", NO)
+    saveFormPos False
+End Sub
+
+Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
+    saveFormPos True
+End Sub
+
+Sub saveFormPos(bDoSave As Boolean)
+    Dim dL, dT
+    If bDoSave Then 'save position
+         SaveSetting TOOLNAME, SECTION, "form_left", Me.Left
+         SaveSetting TOOLNAME, SECTION, "form_top", Me.Top
+    Else 'place instead.
+        dL = GetSetting(TOOLNAME, SECTION, "form_left", 900)
+        dT = GetSetting(TOOLNAME, SECTION, "form_top", 200)
+        Me.Left = dL: Me.Top = dT
+    End If
+End Sub
+
+Private Sub OptDoc_Click()
+    SaveSetting TOOLNAME, SECTION, "InDoc", CStr(OptDoc)
+End Sub
+Private Sub Optlayer_Click()
+    SaveSetting TOOLNAME, SECTION, "InLayer", CStr(Optlayer)
+End Sub
+Private Sub Optpage_Click()
+    SaveSetting TOOLNAME, SECTION, "InPage", CStr(Optpage)
+End Sub
+Private Sub chkColorMark_Click()
+    SaveSetting TOOLNAME, SECTION, "ColorMark", CStr(chkColorMark)
+End Sub
+Private Sub chkIndiv_Click()
+    SaveSetting TOOLNAME, SECTION, "Indiv", CStr(chkIndiv)
+End Sub
+Private Sub chkFill_Click()
+    SaveSetting TOOLNAME, SECTION, "Fill", CStr(chkFill)
+End Sub
+Private Sub chkInGroups_Click()
+    SaveSetting TOOLNAME, SECTION, "InGroups", CStr(chkInGroups)
+End Sub
+Private Sub chkNodes_Click()
+    SaveSetting TOOLNAME, SECTION, "Nodes", CStr(chkNodes)
+End Sub
+Private Sub chkSegments_Click()
+    SaveSetting TOOLNAME, SECTION, "Segments", CStr(chkSegments)
+End Sub
+Private Sub chkOutline_Click()
+    SaveSetting TOOLNAME, SECTION, "Outline", CStr(chkOutline)
+End Sub
+Private Sub chkOutlineColor_Click()
+    SaveSetting TOOLNAME, SECTION, "OutlineColor", CStr(chkOutlineColor)
+End Sub
+Private Sub chkPaths_Click()
+    SaveSetting TOOLNAME, SECTION, "Paths", CStr(chkPaths)
+End Sub
+Private Sub chkSize_Click()
+    SaveSetting TOOLNAME, SECTION, "Size", CStr(chkSize)
+End Sub
+Private Sub chkWHratio_Click()
+    SaveSetting TOOLNAME, SECTION, "WHratio", CStr(chkWHratio)
+End Sub
+Private Sub chkType_Click()
+    SaveSetting TOOLNAME, SECTION, "Type", CStr(chkType)
+End Sub
+Private Sub chkOutLineLength_Click()
+    SaveSetting TOOLNAME, SECTION, "OutlineLength", CStr(chkOutlineLength)
+End Sub

zerobase/splash.frm

@@ -6,7 +6,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} splash
    ClientTop       =   330
    ClientWidth     =   8100
    OleObjectBlob   =   "splash.frx":0000
-   StartUpPosition =   1  '鎵€鏈夎€呬腑蹇�
+   StartUpPosition =   1  'CenterOwner
 End
 Attribute VB_Name = "splash"
 Attribute VB_GlobalNameSpace = False
@@ -38,6 +38,10 @@ Private Const WS_EX_DLGMODALFRAME = &H1&
 Private switch As Boolean
 
 
+Private Sub Image1_Click()
+
+End Sub
+
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
   Dim hWnd As Long
@@ -53,15 +57,15 @@ Private Sub UserForm_Initialize()
 
 End Sub
 
-' 缁忚繃浼樺寲鏀瑰啓锛屽媺寮哄�鐢ㄤ簡
+' 经过优化改写，勉强够用了
 Private Sub UserForm_Activate()
-  Me.text1 = Me.text1 + "鍔熻兘:鎸夐潰绉�帓鍒�"
+  Me.text1 = Me.text1 + "功能:按面积排列"
   
   Unload VBA_FORM
   ActiveWindow.Refresh:    Application.Refresh
   DoEvents
 
-  Tools.鎸夐潰绉�帓鍒� 50
+  Tools.按面积排列 50
   
   'Close the window.
   Unload Me

zerobase/快捷键.bas

@@ -0,0 +1,18 @@
+Attribute VB_Name = "快捷键"
+Sub 木头人群组()
+  autogroup("group", 1).CreateSelection
+End Sub
+
+Sub 角转平()
+  Tools.角度转平
+End Sub
+
+Sub 对象交换()
+  Tools.交换对象
+End Sub
+
+Sub 安全线()
+    Tools.guideangle ActiveSelectionRange, 0#   ' 右键 0距离贴紧
+End Sub
+
+