蘭雅CorelVBA工具箱 0520完整版源码更新

UI/CQL_FIND_UI.bas

@@ -1,20 +1,85 @@
-Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+#If VBA7 Then
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    
+#Else
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+#End If
+Private Const GWL_STYLE As Long = (-16)
+Private Const GWL_EXSTYLE = (-20)
+Private Const WS_CAPTION As Long = &HC00000
+Private Const WS_EX_DLGMODALFRAME = &H1&
+
+Private Sub Close_Icon_Click()
+  Unload Me    ' 关闭
+End Sub
+
+Private Sub UserForm_Initialize()
+  Dim IStyle As Long
+  Dim Hwnd As Long
+  
+  Hwnd = FindWindow("ThunderDFrame", Me.Caption)
+
+  IStyle = GetWindowLong(Hwnd, GWL_STYLE)
+  IStyle = IStyle And Not WS_CAPTION
+  SetWindowLong Hwnd, GWL_STYLE, IStyle
+  DrawMenuBar Hwnd
+  IStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong Hwnd, GWL_EXSTYLE, IStyle
+
+  With Me
+  '  .StartUpPosition = 0
+  '  .Left = 500
+  '  .Top = 200
+    .Width = 378
+    .Height = 228
+  End With
+  
+End Sub
+
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    mX = x
+    mY = y
+  End If
+End Sub
+
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    Me.Move Me.Left - mX + x, Me.TOP - mY + y
+  End If
+End Sub
+
+Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
   Dim pos_x As Variant
-  Dim pos_Y As Variant
+  Dim pos_y As Variant
   pos_x = Array(307, 27)
-  pos_Y = Array(64, 126, 188, 200)
+  pos_y = Array(64, 126, 188, 200)
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(0)) < 30 Then
     Call CQLSameUniformColor
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(1)) < 30 Then
     Call CQLSameOutlineColor
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(2)) < 30 Then
     Call CQLSameSize
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(3)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(y - pos_y(3)) < 30 Then
     CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
   
-  CQL_FIND_UI.Hide   ' show
+  '// 预置颜色轮廓选择
+  If Abs(x - 178) < 30 And Abs(y - 118) < 30 Then
+    Debug.Print "选择图标: " & x & "  , " & y
+    CQL查找相同.CQLline_CM100
+  End If
+  
+  CQL_FIND_UI.Hide
 End Sub
 
 Private Sub CQLSameSize()
@@ -23,9 +88,9 @@ Private Sub CQLSameSize()
   Set s = ActiveShape
   If s Is Nothing Then Exit Sub
     
-  If OptBt.Value = True Then
+  If OptBt.value = True Then
     ActiveDocument.ClearSelection
-    OptBt.Value = 0
+    OptBt.value = 0
     CQL_FIND_UI.Hide
     
     Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
@@ -54,9 +119,9 @@ Private Sub CQLSameOutlineColor()
   G = colr.RGBGreen
   b = colr.RGBBlue
   
-  If OptBt.Value = True Then
+  If OptBt.value = True Then
     ActiveDocument.ClearSelection
-    OptBt.Value = 0
+    OptBt.value = 0
     CQL_FIND_UI.Hide
     
     Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
@@ -90,9 +155,9 @@ Private Sub CQLSameUniformColor()
   G = colr.RGBGreen
   b = colr.RGBBlue
   
-  If OptBt.Value = True Then
+  If OptBt.value = True Then
     ActiveDocument.ClearSelection
-    OptBt.Value = 0
+    OptBt.value = 0
     CQL_FIND_UI.Hide
     
     Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double

UI/CorelVBA.bas

@@ -1,70 +1,146 @@
 #If VBA7 Then
     Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
     Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    
 #Else
-  Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
-  Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+  Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 #End If
 
-Option Explicit
+Private Const GWL_STYLE As Long = (-16)
+Private Const GWL_EXSTYLE = (-20)
+Private Const WS_CAPTION As Long = &HC00000
+Private Const WS_EX_DLGMODALFRAME = &H1&
+Private switch As Boolean
+
+Private Sub Close_Icon_Click()
+  Unload Me    ' 关闭
+End Sub
+
+Private Sub ToolBar_show_Click()
+  Unload Me
+  ToolBar.Show 0
+End Sub
+
+Private Sub UserForm_Initialize()
+  Dim IStyle As Long
+  Dim Hwnd As Long
+  
+  Hwnd = FindWindow("ThunderDFrame", Me.Caption)
+
+  IStyle = GetWindowLong(Hwnd, GWL_STYLE)
+  IStyle = IStyle And Not WS_CAPTION
+  SetWindowLong Hwnd, GWL_STYLE, IStyle
+  DrawMenuBar Hwnd
+  IStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong Hwnd, GWL_EXSTYLE, IStyle
+
+  With Me
+  '  .StartUpPosition = 0
+  '  .Left = 500
+  '  .Top = 200
+    .Width = 385.5
+    .Height = 271.45
+  End With
+  
+End Sub
+
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    mX = x
+    mY = y
+  End If
+End Sub
+
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    Me.Move Me.Left - mX + x, Me.TOP - mY + y
+  End If
+End Sub
 
 Private Sub CommandButton1_Click()
-  TextBox1.Value = "设置出血和裁切线功能目前有个想法。谁有兴趣制作漂亮的图标请联系我."
-  MsgBox "请每天点击右边Logo，点击博客广告一次!" & vbNewLine & "您的支持，我才能有动力添加更多功能."
+  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA青年节版公测" & vbNewLine & "coreldrawvba插件交流群  8531411"
 End Sub
 
-Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
 
   ' 定义图标坐标pos
   Dim pos_x As Variant
-  Dim pos_Y As Variant
+  Dim pos_y As Variant
   pos_x = Array(32, 110, 186, 265, 345)
-  pos_Y = Array(50, 135, 215)
+  pos_y = Array(50, 135, 215)
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(0)) < 30 Then
     物件角线
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(y - pos_y(0)) < 30 Then
     绘制矩形
-  ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(2)) < 30 And Abs(y - pos_y(0)) < 30 Then
     角线爬虫
-  ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(3)) < 30 And Abs(y - pos_y(0)) < 30 Then
     矩形拼版
-  ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
+  ElseIf Abs(x - pos_x(4)) < 30 And Abs(y - pos_y(0)) < 30 Then
     拼版角线
   End If
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
-    居中页面
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(1)) < 30 Then
+    Tools.居中页面
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(y - pos_y(1)) < 30 Then
     拼版标记
-  ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(2)) < 30 And Abs(y - pos_y(1)) < 30 Then
     智能群组
-  ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(3)) < 30 And Abs(y - pos_y(1)) < 30 Then
     CQL选择
-  ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(4)) < 30 And Abs(y - pos_y(1)) < 30 Then
     批量替换
   End If
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
-    尺寸取整
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
-    Dim r As Long
-  ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
-    WebHelp "https://262235.xyz"
-  ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
-    WebHelp "https://262235.xyz"
-  ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
-    WebHelp "https://262235.xyz"
+  If Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(2)) < 30 Then
+    Tools.尺寸取整
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(y - pos_y(2)) < 30 Then
+    Tools.TextShape_ConvertToCurves
+  ElseIf Abs(x - pos_x(2)) < 30 And Abs(y - pos_y(2)) < 30 Then
+    Dim h As Long, r As Long
+    mypath = Path & "GMS\262235.xyz\"
+    app = mypath & "GuiAdobeThumbnail.exe"
+    
+    h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
+    i = ShellExecute(h, "", app, "", mypath, 1)
+
+  ElseIf Abs(x - pos_x(3)) < 30 And Abs(y - pos_y(2)) < 30 Then
+    If switch Then
+      switch = Not switch
+      Tools.傻瓜火车排列
+    Else
+      switch = Not switch
+      Tools.傻瓜阶梯排列
+    End If
+    
+  ElseIf Abs(x - pos_x(4)) < 30 And Abs(y - pos_y(2)) < 30 Then
+    学习CorelVBA实验室
+  End If
+
+  
+  If Abs(x - 210) < 30 And Abs(y - 261) < 8 Then
+    WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
 
 End Sub
 
 Function WebHelp(url As String)
 Dim h As Long, r As Long
-h = FindWindow(vbNullString, "262235.xyz 老人关怀版  By 蘭雅sRGB 2022")
+h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
 r = ShellExecute(h, "", url, "", "", 1)
 End Function
 
+
 Private Sub 绘制矩形()
   剪贴板尺寸建立矩形.start
 End Sub
@@ -103,35 +179,9 @@ Private Sub CQL选择()
   CQL_FIND_UI.Show 0
 End Sub
 
-Private Sub 居中页面()
-  ' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
-  ActiveDocument.Unit = cdrMillimeter
-  Dim OrigSelection As ShapeRange, sh As Shape
-  Set OrigSelection = ActiveSelectionRange
-  Set sh = OrigSelection.Group
-  ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
-  
-#If VBA7 Then
-  ActiveDocument.ClearSelection
-  sh.AddToSelection
-  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
-#Else
-  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
-#End If
-End Sub
-
-Private Sub 尺寸取整()
-  ActiveDocument.Unit = cdrMillimeter
-  Dim sh As Shape, shs As Shapes
-  Set shs = ActiveSelection.Shapes
-  Dim s As String, size As String
-  For Each sh In shs
-    size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
-    sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
-    
-    s = s & size & vbNewLine
-  Next sh
 
-  MsgBox "物件尺寸信息到剪贴板" & vbNewLine & s
-  API.WriteClipBoard s
+Private Sub 学习CorelVBA实验室()
+  CorelVBA.Hide
+  ' 调用语句
+  i = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
 End Sub

UI/Replace_UI.bas

@@ -1,17 +1,77 @@
+#If VBA7 Then
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    
+#Else
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+#End If
+Private Const GWL_STYLE As Long = (-16)
+Private Const GWL_EXSTYLE = (-20)
+Private Const WS_CAPTION As Long = &HC00000
+Private Const WS_EX_DLGMODALFRAME = &H1&
+
+
+Private Sub Close_Icon_Click()
+  Unload Me    ' 关闭
+End Sub
+
+Private Sub UserForm_Initialize()
+  Dim IStyle As Long
+  Dim Hwnd As Long
+  
+  Hwnd = FindWindow("ThunderDFrame", Me.Caption)
+
+  IStyle = GetWindowLong(Hwnd, GWL_STYLE)
+  IStyle = IStyle And Not WS_CAPTION
+  SetWindowLong Hwnd, GWL_STYLE, IStyle
+  DrawMenuBar Hwnd
+  IStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong Hwnd, GWL_EXSTYLE, IStyle
+  
+  With Me
+  '  .StartUpPosition = 0
+  '  .Left = 500
+  '  .Top = 200
+    .Width = 378
+    .Height = 228
+  End With
+  
+End Sub
+
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    mX = x
+    mY = y
+  End If
+End Sub
+
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    Me.Move Me.Left - mX + x, Me.TOP - mY + y
+  End If
+End Sub
+
 
-Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
   Dim pos_x As Variant
-  Dim pos_Y As Variant
+  Dim pos_y As Variant
   pos_x = Array(307, 27)
-  pos_Y = Array(64, 126, 188, 200)
+  pos_y = Array(64, 126, 188, 200)
 
-  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
+  If Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(0)) < 30 Then
     Call copy_shape_replace
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(1)) < 30 Then
     Call copy_shape_replace_resize
-  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(2)) < 30 Then
     Call image_replace
-  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(3)) < 30 Then
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(y - pos_y(3)) < 30 Then
     CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
   End If
   
@@ -26,7 +86,7 @@ Private Sub image_replace()
   image_path = API.GetClipBoardString
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -38,11 +98,11 @@ Private Sub image_replace()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
+    sh.GetPosition x, y
+    sc.SetPosition x, y
     
-    sh.GetSize X, Y
-    sc.SetSize X, Y
+    sh.GetSize x, y
+    sc.SetSize x, y
     sh.Delete
     
   Next sh
@@ -64,7 +124,7 @@ Private Sub copy_shape_replace_resize()
 
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -74,11 +134,11 @@ Private Sub copy_shape_replace_resize()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
+    sh.GetPosition x, y
+    sc.SetPosition x, y
     
-    sh.GetSize X, Y
-    sc.SetSize X, Y
+    sh.GetSize x, y
+    sc.SetSize x, y
     sh.Delete
     
   Next sh
@@ -101,7 +161,7 @@ Private Sub copy_shape_replace()
 
   ActiveDocument.ReferencePoint = cdrCenter
   Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
+  Dim x As Double, y As Double
   Set shs = ActiveSelection.Shapes
   cnt = 0
   For Each sh In shs
@@ -111,8 +171,8 @@ Private Sub copy_shape_replace()
     Else
       sc.Duplicate 0, 0
     End If
-    sh.GetPosition X, Y
-    sc.SetPosition X, Y
+    sh.GetPosition x, y
+    sc.SetPosition x, y
     sh.Delete
   Next sh
 

UI/Toolbar.bas

@@ -0,0 +1,189 @@
+#If VBA7 Then
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    
+#Else
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+#End If
+Private Const GWL_STYLE As Long = (-16)
+Private Const GWL_EXSTYLE = (-20)
+Private Const WS_CAPTION As Long = &HC00000
+Private Const WS_EX_DLGMODALFRAME = &H1&
+
+
+Private Sub Close_Icon_Click()
+  Unload Me    ' 关闭
+End Sub
+
+Private Sub UserForm_Initialize()
+  Dim IStyle As Long
+  Dim Hwnd As Long
+  
+  Hwnd = FindWindow("ThunderDFrame", Me.Caption)
+
+  IStyle = GetWindowLong(Hwnd, GWL_STYLE)
+  IStyle = IStyle And Not WS_CAPTION
+  SetWindowLong Hwnd, GWL_STYLE, IStyle
+  DrawMenuBar Hwnd
+  IStyle = GetWindowLong(Hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong Hwnd, GWL_EXSTYLE, IStyle
+  
+  With Me
+  '  .StartUpPosition = 0
+  '  .Left = 500
+  '  .Top = 200
+    .Width = 378
+    .Height = 228
+  End With
+  
+End Sub
+
+Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    mX = x
+    mY = y
+  End If
+End Sub
+
+Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button Then
+    Me.Move Me.Left - mX + x, Me.TOP - mY + y
+  End If
+End Sub
+
+
+Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  Dim pos_x As Variant
+  Dim pos_y As Variant
+  pos_x = Array(307, 27)
+  pos_y = Array(64, 126, 188, 200)
+
+  If Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(0)) < 30 Then
+    Call copy_shape_replace
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(1)) < 30 Then
+    Call copy_shape_replace_resize
+  ElseIf Abs(x - pos_x(0)) < 30 And Abs(y - pos_y(2)) < 30 Then
+    Call image_replace
+  ElseIf Abs(x - pos_x(1)) < 30 And Abs(y - pos_y(3)) < 30 Then
+    CorelVBA.WebHelp "https://262235.xyz/index.php/tag/vba/"
+  End If
+  
+  Replace_UI.Hide
+End Sub
+
+
+Private Sub image_replace()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  Dim image_path As String
+  image_path = API.GetClipBoardString
+  ActiveDocument.ReferencePoint = cdrCenter
+  Dim sh As Shape, shs As Shapes, cs As Shape
+  Dim x As Double, y As Double
+  Set shs = ActiveSelection.Shapes
+  cnt = 0
+  For Each sh In shs
+    If cnt = 0 Then
+      ActiveDocument.ClearSelection
+      ActiveLayer.Import image_path
+      Set sc = ActiveSelection
+      cnt = 1
+    Else
+      sc.Duplicate 0, 0
+    End If
+    sh.GetPosition x, y
+    sc.SetPosition x, y
+    
+    sh.GetSize x, y
+    sc.SetSize x, y
+    sh.Delete
+    
+  Next sh
+
+    '// 代码操作结束恢复窗口刷新
+    ActiveDocument.EndCommandGroup
+    Application.Optimization = False
+    ActiveWindow.Refresh:    Application.Refresh
+Exit Sub
+ErrorHandler:
+    MsgBox "请先复制图片的完整路径，本工具能自动替换图片!"
+    Application.Optimization = False
+    On Error Resume Next
+End Sub
+
+Private Sub copy_shape_replace_resize()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+
+  ActiveDocument.ReferencePoint = cdrCenter
+  Dim sh As Shape, shs As Shapes, cs As Shape
+  Dim x As Double, y As Double
+  Set shs = ActiveSelection.Shapes
+  cnt = 0
+  For Each sh In shs
+    If cnt = 0 Then
+      Set sc = ActiveDocument.ActiveLayer.Paste
+      cnt = 1
+    Else
+      sc.Duplicate 0, 0
+    End If
+    sh.GetPosition x, y
+    sc.SetPosition x, y
+    
+    sh.GetSize x, y
+    sc.SetSize x, y
+    sh.Delete
+    
+  Next sh
+
+    '// 代码操作结束恢复窗口刷新
+    ActiveDocument.EndCommandGroup
+    Application.Optimization = False
+    ActiveWindow.Refresh:    Application.Refresh
+Exit Sub
+ErrorHandler:
+    MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
+    Application.Optimization = False
+    On Error Resume Next
+End Sub
+
+
+Private Sub copy_shape_replace()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+
+  ActiveDocument.ReferencePoint = cdrCenter
+  Dim sh As Shape, shs As Shapes, cs As Shape
+  Dim x As Double, y As Double
+  Set shs = ActiveSelection.Shapes
+  cnt = 0
+  For Each sh In shs
+    If cnt = 0 Then
+      Set sc = ActiveDocument.ActiveLayer.Paste
+      cnt = 1
+    Else
+      sc.Duplicate 0, 0
+    End If
+    sh.GetPosition x, y
+    sc.SetPosition x, y
+    sh.Delete
+  Next sh
+
+    '// 代码操作结束恢复窗口刷新
+    ActiveDocument.EndCommandGroup
+    Application.Optimization = False
+    ActiveWindow.Refresh:    Application.Refresh
+Exit Sub
+ErrorHandler:
+    MsgBox "请先复制Ctrl+C，然后选择要替换的物件运行本工具!"
+    Application.Optimization = False
+    On Error Resume Next
+End Sub
+

module/API.bas

@@ -0,0 +1,78 @@
+Attribute VB_Name = "API"
+'// 获得剪贴板文本字符
+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(s As String)
+  On Error Resume Next
+  Dim MyData As New DataObject
+  MyData.SetText s
+  MyData.PutInClipboard
+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
+
+'// 测试数组排序
+Private 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 Sub
+
+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
+

module/CQL查找相同.bas

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

module/CorelVBA窗口.bas

@@ -0,0 +1,6 @@
+Attribute VB_Name = "CorelVBA窗口"
+Public Sub start()
+  ToolBar.Show 0
+' CorelVBA.show 0
+End Sub
+

module/Tools.bas

@@ -0,0 +1,244 @@
+Attribute VB_Name = "Tools"
+Public Function 分分合合()
+  拼版裁切线.arrange
+  
+  CQL查找相同.CQLline_CM100
+  
+  拼版裁切线.Cut_lines
+
+  Dim s As Shape
+  Set s = ActivePage.SelectShapesFromRectangle(ActivePage.LeftX, ActivePage.TopY, ActivePage.RightX, ActivePage.BottomY, True)
+  
+  自动中线色阶条.Auto_ColorMark
+
+End Function
+
+
+Public Function 傻瓜火车排列()
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  Dim ssr As ShapeRange, s As Shape
+  Dim cnt As Integer
+  Set ssr = ActiveSelectionRange
+  cnt = 1
+
+#If VBA7 Then
+'  ssr.sort " @shape1.top>@shape2.top"
+  ssr.Sort " @shape1.left<@shape2.left"
+#Else
+' X4 不支持 ShapeRange.sort
+#End If
+
+  ActiveDocument.ReferencePoint = cdrBottomLeft
+  For Each s In ssr
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
+    cnt = cnt + 1
+  Next s
+
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+End Function
+
+
+Public Function 傻瓜阶梯排列()
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  Dim ssr As ShapeRange, s As Shape
+  Dim cnt As Integer
+  Set ssr = ActiveSelectionRange
+  cnt = 1
+
+#If VBA7 Then
+  ssr.Sort " @shape1.top>@shape2.top"
+'  ssr.sort " @shape1.left<@shape2.left"
+#Else
+' X4 不支持 ShapeRange.sort
+#End If
+
+  ActiveDocument.ReferencePoint = cdrTopLeft
+  For Each s In ssr
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY
+    cnt = cnt + 1
+  Next s
+
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+End Function
+
+'// 文本转曲线
+Public Function TextShape_ConvertToCurves()
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  Dim s As Shape, cnt As Long
+  For Each s In API.FindAllShapes.Shapes.FindShapes(, cdrTextShape)
+    s.ConvertToCurves
+    cnt = cnt + 1
+  Next s
+  MsgBox "转曲物件统计: " & cnt, , "文本转曲线"
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+End Function
+
+
+Public Function copy_shape()
+  Dim OrigSelection As ShapeRange
+  Set OrigSelection = ActiveSelectionRange
+  OrigSelection.Copy
+
+End Function
+
+
+Public Function Rotate_Shapes(n As Double)
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  ActiveDocument.Unit = cdrMillimeter
+  
+  Dim sh As Shape, shs As Shapes
+  Set shs = ActiveSelection.Shapes
+  Dim s As String, size As String
+  For Each sh In shs
+    sh.Rotate n
+  Next sh
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+End Function
+
+Public Function get_shape_size(ByRef sx As Double, ByRef sy As Double)
+  ActiveDocument.Unit = cdrMillimeter
+  Dim sh As ShapeRange
+  Set sh = ActiveSelectionRange
+  sx = sh.SizeWidth
+  sy = sh.SizeHeight
+  sx = Int(sx * 100 + 0.5) / 100
+  sy = Int(sy * 100 + 0.5) / 100
+End Function
+
+Public Function Set_Shapes_size(ByRef sx As Double, ByRef sy As Double)
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  ActiveDocument.Unit = cdrMillimeter
+  ActiveDocument.ReferencePoint = cdrCenter
+  
+  Dim sh As Shape, shs As Shapes
+  Set shs = ActiveSelection.Shapes
+  Dim s As String, size As String
+  For Each sh In shs
+     sh.SizeWidth = sx
+     sh.SizeHeight = sy
+  Next sh
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+End Function
+
+Public Function 尺寸取整()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  ActiveDocument.Unit = cdrMillimeter
+  Dim sh As Shape, shs As Shapes
+  Set shs = ActiveSelection.Shapes
+  Dim s As String, size As String
+  For Each sh In shs
+    size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
+    sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
+    
+    s = s & size & vbNewLine
+  Next sh
+
+  MsgBox "物件尺寸信息到剪贴板" & vbNewLine & s
+  API.WriteClipBoard s
+End Function
+
+Public Function 居中页面()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  ' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
+  ActiveDocument.Unit = cdrMillimeter
+  Dim OrigSelection As ShapeRange, sh As Shape
+  Set OrigSelection = ActiveSelectionRange
+  Set sh = OrigSelection.Group
+  ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
+  
+#If VBA7 Then
+  ActiveDocument.ClearSelection
+  sh.AddToSelection
+  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
+End Function
+
+
+Public Function Python脚本整理尺寸()
+    mypy = Path & "GMS\262235.xyz\整理尺寸.py"
+    cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
+    Shell cmd_line
+End Function
+
+Public Function Python提取条码数字()
+    mypy = Path & "GMS\262235.xyz\提取条码数字.py"
+    cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
+    Shell cmd_line
+End Function
+
+Public Function Python二维码QRCode()
+    mypy = Path & "GMS\262235.xyz\二维码QRCode.py"
+    cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
+    Shell cmd_line
+End Function
+
+Public Function QRCode_replace()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  Dim image_path As String
+  image_path = API.GetClipBoardString
+  ActiveDocument.ReferencePoint = cdrCenter
+  Dim sh As Shape, shs As Shapes, cs As Shape
+  Dim x As Double, y As Double
+  Set shs = ActiveSelection.Shapes
+  cnt = 0
+  For Each sh In shs
+    If cnt = 0 Then
+      ActiveDocument.ClearSelection
+      ActiveLayer.Import image_path
+      Set sc = ActiveSelection
+      cnt = 1
+    Else
+      sc.Duplicate 0, 0
+    End If
+    sh.GetPosition x, y
+    sc.SetPosition x, y
+    
+    sh.GetSize x, y
+    sc.SetSize x, y
+    sh.Delete
+    
+  Next sh
+
+    '// 代码操作结束恢复窗口刷新
+    ActiveDocument.EndCommandGroup
+    Application.Optimization = False
+    ActiveWindow.Refresh:    Application.Refresh
+Exit Function
+ErrorHandler:
+    Application.Optimization = False
+    On Error Resume Next
+End Function
+
+Public Function QRCode_to_Vector()
+  On Error GoTo ErrorHandler
+  
+  Set sr = ActiveSelectionRange
+  With sr(1).Bitmap.Trace(cdrTraceHighQualityImage)
+    .TraceType = cdrTraceHighQualityImage
+    .Smoothing = 50 '数值小则平滑，数值大则细节多
+    .RemoveBackground = False
+    .DeleteOriginalObject = True
+    .Finish
+  End With
+
+  
+Exit Function
+ErrorHandler:
+    On Error Resume Next
+End Function

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

@@ -0,0 +1,107 @@
+Attribute VB_Name = "剪贴板尺寸建立矩形"
+'// Attribute VB_Name = "剪贴板尺寸建立矩形"
+Type Coordinate
+    x As Double
+    y As Double
+End Type
+Public O_O As Coordinate
+
+Sub start()
+    '// 坐标原点
+    O_O.x = 0:   O_O.y = 0
+    Dim ost As ShapeRange
+    Set ost = ActiveSelectionRange
+
+    O_O.x = ost.LeftX
+    O_O.y = ost.BottomY - 50    '选择物件 下移动 50mm
+
+    '// 建立矩形 Width  x Height 单位 mm
+    ' Rectangle 101, 151
+    Dim Str, arr, n
+    Str = API.GetClipBoardString
+
+    ' 替换 mm x * 换行 TAB 为空格
+    Str = VBA.replace(Str, "m", " ")
+    Str = VBA.replace(Str, "x", " ")
+    Str = VBA.replace(Str, "*", " ")
+    Str = VBA.replace(Str, vbNewLine, " ")
+
+    Do While InStr(Str, "  ") '多个空格换成一个空格
+        Str = VBA.replace(Str, "  ", " ")
+    Loop
+    arr = Split(Str)
+    
+    ActiveDocument.BeginCommandGroup  '一步撤消'
+    Dim x As Double
+    Dim y As Double
+    For n = LBound(arr) To UBound(arr) - 1 Step 2
+        ' MsgBox arr(n)
+        x = Val(arr(n))
+        y = Val(arr(n + 1))
+        
+        If x > 0 And y > 0 Then
+            Rectangle x, y
+            O_O.x = O_O.x + x + 30
+        End If
+    Next
+    ActiveDocument.EndCommandGroup
+End Sub
+
+Private Function Rectangle(Width As Double, Height As Double)
+    ActiveDocument.Unit = cdrMillimeter
+    Dim size As Shape
+    Dim d As Document
+    Dim s1 As Shape
+
+    '// 建立矩形 Width  x Height 单位 mm
+    Set s1 = ActiveLayer.CreateRectangle(O_O.x, O_O.y, O_O.x + Width, O_O.y - Height)
+    
+    '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
+    s1.Fill.ApplyNoFill
+    s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
+        
+    sw = s1.SizeWidth
+    sh = s1.SizeHeight
+
+    Text = Trim(Str(sw)) + "x" + Trim(Str(sh)) + "mm"
+    Set d = ActiveDocument
+    Set size = d.ActiveLayer.CreateArtisticText(O_O.x + sw / 2 - 25, O_O.y + 10, Text, Font:="Tahoma")  '// O_O.y + 10  标注尺寸上移 10mm
+    size.Fill.UniformColor.CMYKAssign 0, 100, 100, 0
+End Function
+
+Private Function setRectangle(Width As Double, Height As Double)
+
+    Dim s1 As Shape
+    Set s1 = ActiveSelection
+    ActiveDocument.Unit = cdrMillimeter
+    '// 物件中心基准, 先把宽度设定为
+    ActiveDocument.ReferencePoint = cdrCenter
+    s1.SetSize Height, Height
+
+    '// 物件旋转 30度，轮廓线1mm ,轮廓颜色 M100Y100
+    s1.Rotate 30#
+    s1.Outline.SetProperties 1#
+    s1.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 100, 0)
+
+End Function
+
+
+'// 获得选择物件大小信息
+Sub get_all_size()
+  ActiveDocument.Unit = cdrMillimeter
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.CreateTextFile("R:\size.txt", True)
+  Dim sh As Shape, shs As Shapes
+  Set shs = ActiveSelection.Shapes
+  Dim s As String
+  For Each sh In shs
+    size = Trim(Str(Int(sh.SizeWidth + 0.5))) + "x" + Trim(Str(Int(sh.SizeHeight + 0.5))) + "mm"
+    f.WriteLine (size)
+    s = s + size + vbNewLine
+  Next sh
+  f.Close
+  MsgBox "输出物件尺寸信息到文件" & "R:\size.txt" & vbNewLine & s
+  API.WriteClipBoard s
+End Sub
+
+

module/拼版裁切线.bas

@@ -0,0 +1,194 @@
+Attribute VB_Name = "拼版裁切线"
+Type Coordinate
+    x As Double
+    y As Double
+End Type
+
+Sub Cut_lines()
+  If 0 = ActiveSelectionRange.Count Then Exit Sub
+  '// 代码运行时关闭窗口刷新
+  Application.Optimization = True
+  ActiveDocument.BeginCommandGroup  '一步撤消'
+  ActiveDocument.Unit = cdrMillimeter
+  Dim OrigSelection As ShapeRange
+  Set OrigSelection = ActiveSelectionRange
+  
+  Dim s1 As Shape, sbd As Shape
+  Dim dot As Coordinate
+  Dim arr As Variant, border As Variant
+  
+  ' 当前选择物件的范围边界
+  set_lx = OrigSelection.LeftX:   set_rx = OrigSelection.RightX
+  set_by = OrigSelection.BottomY: set_ty = OrigSelection.TopY
+  set_cx = OrigSelection.CenterX: set_cy = OrigSelection.CenterY
+  radius = 8:  border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius)
+  
+  ' 创建边界矩形，用来添加角线
+  Set sbd = ActiveLayer.CreateRectangle(set_lx, set_by, set_rx, set_ty)
+  OrigSelection.Add sbd
+  
+  For Each Target In OrigSelection
+    Set s1 = Target
+    lx = s1.LeftX:   rx = s1.RightX
+    by = s1.BottomY: ty = s1.TopY
+    cx = s1.CenterX: cy = s1.CenterY
+    
+    '// 范围边界物件判断
+    If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - by) _
+      < radius Or Abs(set_ty - ty) < radius Then
+      
+      arr = Array(lx, by, rx, by, lx, ty, rx, ty)  '// 物件左下-右下-左上-右上 四个顶点坐标数组
+      For i = 0 To 3
+        dot.x = arr(2 * i)
+        dot.y = arr(2 * i + 1)
+        
+        '// 范围边界坐标点判断
+        If Abs(set_lx - dot.x) < radius Or Abs(set_rx - dot.x) < radius _
+              Or Abs(set_by - dot.y) < radius Or Abs(set_ty - dot.y) < radius Then
+
+            draw_line dot, border  '// 以坐标点和范围边界画裁切线
+        End If
+      Next i
+    End If
+  Next Target
+  
+  sbd.Delete  '删除边界矩形
+  
+  '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
+  ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
+  ActiveSelection.Group
+  ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
+  
+  ActiveDocument.EndCommandGroup
+  '// 代码操作结束恢复窗口刷新
+  Application.Optimization = False
+  ActiveWindow.Refresh
+  Application.Refresh
+End Sub
+
+'范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius)
+Private Function draw_line(dot As Coordinate, border As Variant)
+    Bleed = 2:  line_len = 3:  radius = border(6)
+    Dim line As Shape
+
+    If Abs(dot.y - border(3)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(dot.x, border(3) + Bleed, dot.x, border(3) + (line_len + Bleed))
+        set_line_color line
+    ElseIf Abs(dot.y - border(2)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(dot.x, border(2) - Bleed, dot.x, border(2) - (line_len + Bleed))
+        set_line_color line
+    End If
+    
+    If Abs(dot.x - border(1)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.y, border(1) + (line_len + Bleed), dot.y)
+        set_line_color line
+    ElseIf Abs(dot.x - border(0)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.y, border(0) - (line_len + Bleed), dot.y)
+        set_line_color line
+    End If
+
+End Function
+
+'// 旧版本
+Private Function draw_line_按点基准(dot As Coordinate, border As Variant)
+    Bleed = 2:  line_len = 3:  radius = border(6)
+    Dim line As Shape
+
+    If Abs(dot.y - border(3)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y + Bleed, dot.x, dot.y + (line_len + Bleed))
+        set_line_color line
+    ElseIf Abs(dot.y - border(2)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y - Bleed, dot.x, dot.y - (line_len + Bleed))
+        set_line_color line
+    End If
+    
+    If Abs(dot.x - border(1)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(dot.x + Bleed, dot.y, dot.x + (line_len + Bleed), dot.y)
+        set_line_color line
+    ElseIf Abs(dot.x - border(0)) < radius Then
+        Set line = ActiveLayer.CreateLineSegment(dot.x - Bleed, dot.y, dot.x - (line_len + Bleed), dot.y)
+        set_line_color line
+    End If
+
+End Function
+
+Private Function set_line_color(line As Shape)
+    '// 设置线宽和注册色
+   line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
+End Function
+
+'// CorelDRAW 物件排列拼版简单代码
+Sub arrange()
+    On Error GoTo ErrorHandler
+    ActiveDocument.Unit = cdrMillimeter
+    row = 3     ' 拼版 3 x 4
+    List = 4
+    sp = 0       '间隔 0mm
+
+    Dim Str, arr, n
+    Str = API.GetClipBoardString
+
+    ' 替换 mm x * 换行 TAB 为空格
+    Str = VBA.replace(Str, "mm", " ")
+    Str = VBA.replace(Str, "x", " ")
+    Str = VBA.replace(Str, "*", " ")
+    Str = VBA.replace(Str, Chr(13), " ")
+    Str = VBA.replace(Str, Chr(9), " ")
+    
+    Do While InStr(Str, "  ")    '多个空格换成一个空格
+        Str = VBA.replace(Str, "  ", " ")
+    Loop
+    
+    arr = Split(Str)
+
+    Dim s1 As Shape
+    Dim x As Double, y As Double
+    
+    If 0 = ActiveSelectionRange.Count Then
+      x = Val(arr(0)):    y = Val(arr(1))
+      row = Int(ActiveDocument.Pages.First.SizeWidth / x)
+      List = Int(ActiveDocument.Pages.First.SizeHeight / y)
+  
+      If UBound(arr) > 2 Then
+      row = Val(arr(2)):  List = Val(arr(3))
+          If row * List > 800 Then
+            GoTo ErrorHandler
+          ElseIf UBound(arr) > 3 Then
+              sp = Val(arr(4))       '间隔
+          End If
+      End If
+      
+      
+      '// 建立矩形 Width  x Height 单位 mm
+      Set s1 = ActiveLayer.CreateRectangle(0, 0, x, y)
+      
+      '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
+      s1.Fill.ApplyNoFill
+      s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), _
+          ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#
+
+    '// 如果当前选择物件，按当前物件拼版
+    ElseIf 1 = ActiveSelectionRange.Count Then
+      Set s1 = ActiveSelection
+      x = s1.SizeWidth:    y = s1.SizeHeight
+      row = Int(ActiveDocument.Pages.First.SizeWidth / x)
+      List = Int(ActiveDocument.Pages.First.SizeHeight / y)
+    End If
+    
+
+    sw = x:  sh = y
+
+    '// StepAndRepeat 方法在范围内创建多个形状副本
+    Dim dup1 As ShapeRange
+    Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)
+    Dim dup2 As ShapeRange
+    Set dup2 = ActiveDocument.CreateShapeRangeFromArray _
+         (dup1, s1).StepAndRepeat(List - 1, 0#, (sh + sp))
+         
+    Exit Sub
+ErrorHandler:
+     MsgBox "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
+    On Error Resume Next
+End Sub
+
+

module/智能查找.bas

@@ -0,0 +1,70 @@
+Attribute VB_Name = "智能查找"
+Sub 一键加点工具()
+    Dim OrigSelection As ShapeRange
+    Set OrigSelection = ActiveSelectionRange
+    If OrigSelection.Count <> 0 Then
+      OrigSelection.Copy
+    Else
+      MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
+      Exit Sub
+    End If
+    
+    ' 新建文件粘贴
+    Dim doc1 As Document
+    Set doc1 = CreateDocument
+    ActiveLayer.Paste
+    
+    ' 转曲线，一键加粗小红点
+    ActiveSelection.ConvertToCurves
+    Call get_little_points
+End Sub
+
+
+Private Sub get_little_points()
+  On Error GoTo ErrorHandler
+  '// 代码运行时关闭窗口刷新
+  Application.Optimization = True
+  ActiveDocument.BeginCommandGroup  '一步撤消'
+  
+  red_point_Size = 0.3
+  ActiveDocument.Unit = cdrMillimeter
+  Dim OrigSelection As ShapeRange, grp1 As ShapeRange, sh As Shape
+  Set OrigSelection = ActiveSelectionRange
+  Set grp1 = OrigSelection.UngroupAllEx
+  grp1.ApplyUniformFill CreateCMYKColor(50, 0, 0, 0)
+  
+  For Each sh In grp1
+    sh.BreakApartEx
+  Next sh
+  
+  ActiveDocument.ClearSelection
+  Dim sr As ShapeRange
+  Set sr = ActivePage.Shapes.FindShapes(Query:="@width < {" & red_point_Size & " mm} and @width > {0.1 mm} and @height <{" & red_point_Size & " mm} and @height >{0.1 mm}")
+  If sr.Count <> 0 Then
+    sr.CreateSelection
+    Set sh = ActiveSelection.Group
+    sh.Outline.SetProperties 0.03, Color:=CreateCMYKColor(0, 100, 100, 0)
+    sr.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
+    sh.Move 0, 0.015
+    sh.Copy
+  Else
+    MsgBox "文件中小圆点足够大，不需要加粗!"
+  End If
+
+  ActivePage.Shapes.FindShapes(Query:="@colors.find(CMYK(50, 0, 0, 0))").CreateSelection
+  ActiveSelection.Group
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh
+  Application.Refresh
+  Exit Sub
+ErrorHandler:
+     MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
+     Application.Optimization = False
+    On Error Resume Next
+End Sub
+
+Sub 文字转曲()
+  Tools.TextShape_ConvertToCurves
+End Sub

module/智能群组和查找.bas

@@ -0,0 +1,100 @@
+Attribute VB_Name = "智能群组和查找"
+Sub 剪贴板物件替换()
+  Replace_UI.Show 0
+End Sub
+
+Public Sub 智能群组()
+If 0 = ActiveSelectionRange.Count Then Exit Sub
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  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, y, w, h)
+      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
+
+  '// 矩形边界智能群组，删除矩形
+  For Each s In brk1
+    Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
+    sh.Shapes.All.Group
+    s.Delete
+  Next
+
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+Exit Sub
+
+ErrorHandler:
+  Application.Optimization = False
+  MsgBox "请先选择一些物件来确定群组范围!"
+  On Error Resume Next
+
+End Sub
+
+
+Function 智能群组_V1()
+    On Error GoTo ErrorHandler
+    ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+    ActiveDocument.Unit = cdrMillimeter
+    Dim OrigSelection As ShapeRange, brk1 As ShapeRange
+    Set OrigSelection = ActiveSelectionRange
+    Dim s1 As Shape, sh As Shape, s As Shape
+    
+    Set s1 = OrigSelection.CustomCommand("Boundary", "CreateBoundary")
+'   s1.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
+    Set brk1 = s1.BreakApartEx
+
+    For Each s In brk1
+      If s.SizeHeight > 10 Then
+        Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
+        sh.Shapes.All.Group
+      End If
+      s.Delete
+    Next
+    
+'    ActiveDocument.ClearSelection
+'    ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelections
+
+    '// 代码操作结束恢复窗口刷新
+    ActiveDocument.EndCommandGroup
+    Application.Optimization = False
+    ActiveWindow.Refresh:    Application.Refresh
+Exit Function
+ErrorHandler:
+    Application.Optimization = False
+    MsgBox "请先选择一些物件来确定群组范围!"
+    On Error Resume Next
+End Function
+

module/自动中线色阶条.bas

@@ -0,0 +1,314 @@
+Attribute VB_Name = "自动中线色阶条"
+' Attribute VB_Name = "自动中线色阶条"
+'// 请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能
+Sub Auto_ColorMark()
+  If 0 = ActiveSelectionRange.Count Then Exit Sub
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  Dim doc As Document: Set doc = ActiveDocument: doc.Unit = cdrMillimeter
+
+  ' 物件群组，设置页面大小
+  Call set_page_size
+
+  '// 获得页面中心点 x,y
+  px = ActiveDocument.ActivePage.CenterX
+  py = ActiveDocument.ActivePage.CenterY
+  '// 导入色阶条中线对准线标记文件 ColorMark.cdr 解散群组
+  doc.ActiveLayer.Import Path & "GMS\ColorMark.cdr"
+  ActiveDocument.ReferencePoint = cdrBottomMiddle
+  ' ActiveDocument.Selection.SetPosition px, -100
+  ActiveDocument.Selection.Ungroup
+
+  Dim sh As Shape, shs As Shapes
+  Set shs = ActiveSelection.Shapes
+  '// 按 MarkName 名称查找放置中线对准线标记等
+  For Each sh In shs
+  ActiveDocument.ClearSelection
+  sh.CreateSelection
+  If "CenterLine" = sh.ObjectData("MarkName").value Then
+      put_center_line sh
+      
+  ElseIf "TargetLine" = sh.ObjectData("MarkName").value Then
+      put_target_line sh
+
+  ElseIf "ColorStrip" = sh.ObjectData("MarkName").value Then
+    ' put_ColorStrip sh   ' 放置彩色色阶条
+
+     sh.Delete  ' 工厂定置不用色阶条
+
+  ElseIf "ColorMark" = sh.ObjectData("MarkName").value Then
+      ' CMYK四色标记放置咬口
+      If (px > py) Then
+      sh.SetPosition px + 25#, 0
+      Else
+      sh.Rotate 270#
+      ActiveDocument.ReferencePoint = cdrBottomLeft
+      sh.SetPosition 0, py - 42#
+      End If
+      sh.OrderToBack
+  Else
+      sh.Delete   ' 没找到标记 ColorMark 删除
+  
+  End If
+  Next sh
+
+  ' 标准页面大小和添加页面框
+  put_page_size
+  put_page_line
+  
+  '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
+  ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
+  ActiveSelection.Group
+  ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
+
+  '// 代码操作结束恢复窗口刷新
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+Exit Sub
+ErrorHandler:
+  MsgBox "请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能!"
+  Application.Optimization = False
+  On Error Resume Next
+End Sub
+
+Private Sub set_page_size()
+  ' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
+  ActiveDocument.Unit = cdrMillimeter
+  Dim OrigSelection As ShapeRange, sh As Shape
+  Set OrigSelection = ActiveSelectionRange
+  Set sh = OrigSelection.Group
+  
+  ' MsgBox "选择物件尺寸: " & sh.SizeWidth & "x" & sh.SizeHeight
+  ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
+
+#If VBA7 Then
+  ActiveDocument.ClearSelection
+  sh.AddToSelection
+  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
+
+End Sub
+
+Private Function set_line_color(line As Shape)
+    '// 设置线宽和注册色
+   line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
+End Function
+
+Private Function put_page_line()
+    ' 添加页面框线
+    Dim s1 As Shape
+    Set s1 = ActiveLayer.CreateRectangle2(0, 0, ActivePage.SizeWidth, ActivePage.SizeHeight)
+    s1.Fill.ApplyNoFill:    s1.OrderToBack
+    s1.Outline.SetProperties 0.01, Color:=CreateCMYKColor(100, 0, 0, 0)
+End Function
+
+'''---------  CorelDRAW X4 和 高版本 对齐页面API不同 ------------------'''
+#If VBA7 Then
+
+Private Function put_center_line(sh As Shape)
+    ' 在页面四边放置中线
+    set_line_color sh
+    sh.AlignAndDistribute 3, 1, 1, 0, False, 2
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignAndDistribute 3, 2, 1, 0, False, 2
+    sh.Duplicate 0, 0
+    sh.Rotate 90
+    sh.AlignAndDistribute 1, 3, 1, 0, False, 2
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignAndDistribute 2, 3, 1, 0, False, 2
+End Function
+
+Private Function put_target_line(sh As Shape)
+    ' 在页面四角放置套准标记线
+    set_line_color sh
+    sh.AlignAndDistribute 2, 1, 1, 0, False, 2
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignAndDistribute 1, 2, 1, 0, False, 2
+    sh.Duplicate 0, 0
+    sh.Flip cdrFlipHorizontal   ' 物件镜像
+    sh.AlignAndDistribute 2, 2, 1, 0, False, 2
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignAndDistribute 1, 1, 1, 0, False, 2
+End Function
+
+Private Function put_ColorStrip(sh As Shape)
+  ' 在页面四边放置色阶条
+    sh.OrderToBack
+  If ActivePage.SizeWidth >= ActivePage.SizeHeight Then
+    sh.AlignAndDistribute 2, 1, 1, 0, False, 2
+    sh.Duplicate 5, 0
+    sh.AlignAndDistribute 1, 1, 1, 0, False, 2
+    sh.Duplicate -25, 0
+    sh.Rotate 90
+    sh.AlignAndDistribute 2, 2, 1, 0, False, 2
+    sh.Duplicate 0, 5
+    sh.AlignAndDistribute 1, 2, 1, 0, False, 2
+    sh.Move 0, 5
+  Else
+    sh.AlignAndDistribute 2, 1, 1, 0, False, 2
+    sh.Duplicate 5, 0
+    sh.AlignAndDistribute 2, 2, 1, 0, False, 2
+    sh.Duplicate 5, 0
+    sh.Rotate 270
+    sh.AlignAndDistribute 1, 1, 1, 0, False, 2
+    sh.Duplicate 0, -5
+    sh.AlignAndDistribute 2, 2, 1, 0, False, 2
+    sh.Move 0, 25
+  End If
+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 = size & " " & ActiveDocument.FileName & " " & Date & vbNewLine & "Https://262235.xyz 需要您的支持!"
+    Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 7)
+End Function
+
+#Else
+'''---------  CorelDRAW X4 对齐页面API ------------------'''
+
+Private Function put_target_line(sh As Shape)
+    ' 在页面四角放置套准标记线  Set sh = ActiveDocument.Selection
+    set_line_color sh
+    sh.AlignToPage cdrAlignLeft + cdrAlignTop
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignToPage cdrAlignRight + cdrAlignBottom
+    sh.Duplicate 0, 0
+    sh.Flip cdrFlipHorizontal   ' 物件镜像
+    sh.AlignToPage cdrAlignLeft + cdrAlignBottom
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignToPage cdrAlignRight + cdrAlignTop
+End Function
+
+Private Function put_center_line(sh As Shape)
+    ' 在页面四边放置中线 Set sh = ActiveDocument.Selection
+    set_line_color sh
+    sh.AlignToPage cdrAlignHCenter + cdrAlignTop
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignToPage cdrAlignHCenter + cdrAlignBottom
+    sh.Duplicate 0, 0
+    sh.Rotate 90
+    sh.AlignToPage cdrAlignVCenter + cdrAlignRight
+    sh.Duplicate 0, 0
+    sh.Rotate 180
+    sh.AlignToPage cdrAlignVCenter + cdrAlignLeft
+End Function
+
+Private Function put_ColorStrip(sh As Shape)
+  ' 在页面四边放置色阶条 Set sh = ActiveDocument.Selection
+    sh.OrderToBack
+  If ActivePage.SizeWidth >= ActivePage.SizeHeight Then
+    sh.AlignToPage cdrAlignLeft + cdrAlignTop
+    sh.Duplicate 5, 0
+    sh.AlignToPage cdrAlignRight + cdrAlignTop
+    sh.Duplicate -25, 0
+    sh.Rotate 90
+    sh.AlignToPage cdrAlignLeft + cdrAlignBottom
+    sh.Duplicate 0, 5
+    sh.AlignToPage cdrAlignRight + cdrAlignBottom
+    sh.Move 0, 5
+  Else
+    sh.AlignToPage cdrAlignLeft + cdrAlignTop
+    sh.Duplicate 5, 0
+    sh.AlignToPage cdrAlignLeft + cdrAlignBottom
+    sh.Duplicate 5, 0
+    sh.Rotate 270
+    sh.AlignToPage cdrAlignRight + cdrAlignTop
+    sh.Duplicate 0, -5
+    sh.AlignToPage cdrAlignRight + cdrAlignBottom
+    sh.Move 0, 25
+  End If
+End Function
+
+Private Function put_page_size()
+    ' 添加文字 页面大小
+    Dim st As Shape
+    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
+End Function
+
+#End If
+
+
+
+Sub Auto_ColorMark_K()
+  If 0 = ActiveSelectionRange.Count Then Exit Sub
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  Dim doc As Document: Set doc = ActiveDocument: doc.Unit = cdrMillimeter
+
+  ' 物件群组，设置页面大小
+  Call set_page_size
+
+  '// 获得页面中心点 x,y
+  px = ActiveDocument.ActivePage.CenterX
+  py = ActiveDocument.ActivePage.CenterY
+  '// 导入色阶条中线对准线标记文件 ColorMark.cdr 解散群组
+  doc.ActiveLayer.Import Path & "GMS\ColorMark.cdr"
+  ActiveDocument.ReferencePoint = cdrBottomMiddle
+  ' ActiveDocument.Selection.SetPosition px, -100
+  ActiveDocument.Selection.Ungroup
+
+  Dim sh As Shape, shs As Shapes
+  Set shs = ActiveSelection.Shapes
+  '// 按 MarkName 名称查找放置中线对准线标记等
+  For Each sh In shs
+  ActiveDocument.ClearSelection
+  sh.CreateSelection
+  If "CenterLine" = sh.ObjectData("MarkName").value Then
+      put_center_line sh
+      
+  ElseIf "TargetLine" = sh.ObjectData("MarkName").value Then
+      put_target_line sh
+
+  ElseIf "ColorStrip" = sh.ObjectData("MarkName").value Then
+     sh.Delete  ' 工厂定置不用色阶条
+
+  ElseIf "ColorMark_K" = sh.ObjectData("MarkName").value Then
+      ' 只放置单色黑
+      If (px > py) Then
+      sh.SetPosition px + 25#, 0
+      Else
+      sh.Rotate 270#
+      ActiveDocument.ReferencePoint = cdrBottomLeft
+      sh.SetPosition 0, py - 42#
+      End If
+      sh.OrderToBack
+  Else
+      sh.Delete   ' 没找到标记 ColorMark 删除
+  
+  End If
+  Next sh
+
+  ' 标准页面大小和添加页面框
+  put_page_size
+  put_page_line
+  
+  '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
+  ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
+  ActiveSelection.Group
+  ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
+
+  '// 代码操作结束恢复窗口刷新
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+Exit Sub
+ErrorHandler:
+  MsgBox "请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能!"
+  Application.Optimization = False
+  On Error Resume Next
+End Sub

module/裁切线.bas

@@ -0,0 +1,118 @@
+Attribute VB_Name = "裁切线"
+' Attribute VB_Name = "裁切线"
+Sub start()
+If 0 = ActiveSelectionRange.Count Then Exit Sub
+  '// 代码运行时关闭窗口刷新
+  Application.Optimization = True
+  ActiveDocument.BeginCommandGroup  '一步撤消'
+
+   '// 设置当前文档 尺寸单位mm 出血和线长
+  ActiveDocument.Unit = cdrMillimeter
+  Bleed = 2
+  line_len = 3
+
+  Dim OrigSelection As ShapeRange
+  Set OrigSelection = ActiveSelectionRange
+  
+  '// 定义当前选择物件 分别获得 左右下上中心坐标(x,y)和尺寸信息
+  Dim s1 As Shape
+
+  For Each Target In OrigSelection
+      Set s1 = Target
+      lx = s1.LeftX:      rx = s1.RightX
+      by = s1.BottomY:    ty = s1.TopY
+      cx = s1.CenterX:    cy = s1.CenterY
+      sw = s1.SizeWidth:  sh = s1.SizeHeight
+      
+      '//  添加裁切线，分别左下-右下-左上-右上
+      Dim s2, s3, s4, s5, s6, s7, s8, s9 As Shape
+      Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, by, lx - (Bleed + line_len), by)
+      Set s3 = ActiveLayer.CreateLineSegment(lx, by - Bleed, lx, by - (Bleed + line_len))
+
+      Set s4 = ActiveLayer.CreateLineSegment(rx + Bleed, by, rx + (Bleed + line_len), by)
+      Set s5 = ActiveLayer.CreateLineSegment(rx, by - Bleed, rx, by - (Bleed + line_len))
+
+      Set s6 = ActiveLayer.CreateLineSegment(lx - Bleed, ty, lx - (Bleed + line_len), ty)
+      Set s7 = ActiveLayer.CreateLineSegment(lx, ty + Bleed, lx, ty + (Bleed + line_len))
+
+      Set s8 = ActiveLayer.CreateLineSegment(rx + Bleed, ty, rx + (Bleed + line_len), ty)
+      Set s9 = ActiveLayer.CreateLineSegment(rx, ty + Bleed, rx, ty + (Bleed + line_len))
+
+      '// 选中裁切线 群组 设置线宽和注册色
+      ActiveDocument.AddToSelection s2, s3, s4, s5, s6, s7, s8, s9
+      ActiveSelection.Group
+      ActiveSelection.Outline.SetProperties 0.1
+      ActiveSelection.Outline.SetProperties Color:=CreateRegistrationColor
+  
+  Next Target
+
+  ActiveDocument.EndCommandGroup
+  '// 代码操作结束恢复窗口刷新
+  Application.Optimization = False
+  ActiveWindow.Refresh
+  Application.Refresh
+End Sub
+
+
+
+'// 单线条转裁切线 - 放置到页面四边
+Sub SelectLine_to_Cropline()
+  If 0 = ActiveSelectionRange.Count Then Exit Sub
+  '// 代码运行时关闭窗口刷新
+  Application.Optimization = True
+  ActiveDocument.Unit = cdrMillimeter
+  
+  ActiveDocument.BeginCommandGroup  '一步撤消'
+  
+  '// 获得页面中心点 x,y
+  px = ActiveDocument.Pages.First.CenterX
+  py = ActiveDocument.Pages.First.CenterY
+  Bleed = 2
+  line_len = 3
+  
+  Dim s As Shape
+  Dim line As Shape
+  
+  '// 遍历选择的线条
+  For Each s In ActiveSelection.Shapes
+  
+      lx = s.LeftX
+      rx = s.RightX
+      by = s.BottomY
+      ty = s.TopY
+      
+      cx = s.CenterX
+      cy = s.CenterY
+      sw = s.SizeWidth
+      sh = s.SizeHeight
+     
+     '// 判断横线(高度小于宽度)，在页面左边还是右边
+     If sh <= sw Then
+      s.Delete
+      If cx < px Then
+          Set line = ActiveLayer.CreateLineSegment(0, cy, 0 + line_len, cy)
+      Else
+          Set line = ActiveLayer.CreateLineSegment(px * 2, cy, px * 2 - line_len, cy)
+      End If
+     End If
+   
+     '// 判断竖线(高度大于宽度)，在页面下边还是上边
+     If sh > sw Then
+      s.Delete
+      If cy < py Then
+          Set line = ActiveLayer.CreateLineSegment(cx, 0, cx, 0 + line_len)
+      Else
+          Set line = ActiveLayer.CreateLineSegment(cx, py * 2, cx, py * 2 - line_len)
+      End If
+     End If
+  
+      line.Outline.SetProperties 0.1
+      line.Outline.SetProperties Color:=CreateRegistrationColor
+  Next s
+  
+  ActiveDocument.EndCommandGroup
+  '// 代码操作结束恢复窗口刷新
+  Application.Optimization = False
+  ActiveWindow.Refresh
+  Application.Refresh
+End Sub