蘭雅CorelVBA工具-中秋版 更换UI图

UI/CQL_FIND_UI.bas

@@ -13,6 +13,7 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
 #If VBA7 Then
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
@@ -36,6 +37,7 @@ Private Sub Close_Icon_Click()
   Unload Me    ' 关闭
 End Sub
 
+
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
   Dim Hwnd As Long

UI/CorelVBA.bas

@@ -1,6 +1,6 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CorelVBA 
-   Caption         =   "CorelVBA 青年节 By 蘭雅sRGB 2022"
+   Caption         =   "CorelVBA 中秋节版 By 蘭雅sRGB 2022"
    ClientHeight    =   5415
    ClientLeft      =   45
    ClientTop       =   330
@@ -13,6 +13,8 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
+
 #If VBA7 Then
     Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
@@ -42,7 +44,7 @@ End Sub
 
 Private Sub ToolBar_show_Click()
   Unload Me
-  ToolBar.Show 0
+  Toolbar.Show 0
 End Sub
 
 Private Sub UserForm_Initialize()
@@ -66,6 +68,10 @@ Private Sub UserForm_Initialize()
     .Height = 271.45
   End With
   
+  UIFile = Path & "GMS\262235.xyz\UI.jpg"
+  If API.ExistsFile_UseFso(UIFile) Then
+    UI.Picture = LoadPicture(UIFile)   '换UI图
+  End If
 End Sub
 
 Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
@@ -82,8 +88,8 @@ Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVa
   End If
 End Sub
 
-Private Sub CommandButton1_Click()
-  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA青年节版公测" & vbNewLine & "coreldrawvba插件交流群  8531411"
+Private Sub About_Cmd_Click()
+  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
 End Sub
 
 Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
@@ -133,10 +139,10 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   ElseIf Abs(x - pos_x(3)) < 30 And Abs(y - pos_y(2)) < 30 Then
     If switch Then
       switch = Not switch
-      Tools.傻瓜火车排列
+      Tools.傻瓜火车排列 0#
     Else
       switch = Not switch
-      Tools.傻瓜阶梯排列
+      Tools.傻瓜阶梯排列 0#
     End If
     
   ElseIf Abs(x - pos_x(4)) < 30 And Abs(y - pos_y(2)) < 30 Then

UI/Replace_UI.bas

@@ -13,6 +13,7 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
 #If VBA7 Then
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long

UI/Toolbar.bas

@@ -91,8 +91,8 @@ Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVa
     UI.Visible = True
     LOGO.Visible = False
     X_EXIT.Visible = False
-    LEFT_BT.Visible = False
-    TOP_BT.Visible = False
+    TOP_ALIGN_BT.Visible = False
+    LEFT_ALIGN_BT.Visible = False
     Exit Sub
   End If
   
@@ -144,13 +144,24 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
   
   ElseIf Abs(x - pos_x(6)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
     调用多页合并工具
-  Exit Sub
+    Exit Sub
   
   ElseIf Abs(x - pos_x(8)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
-    '// 扩展工具栏
+    '// 右键扩展工具栏
     Me.Height = 30 + 45
-  Exit Sub
+    Exit Sub
   
+  ElseIf Abs(x - pos_x(10)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    '// 右键排列工具
+    TOP_ALIGN_BT.Visible = True
+    LEFT_ALIGN_BT.Visible = True
+    Exit Sub
+
+  ElseIf Abs(x - pos_x(11)) < 14 And Abs(y - pos_y(0)) < 14 And Button = 2 Then
+    '// 右键扩展工具栏收缩
+    Me.Height = 30
+    Exit Sub
+
   End If
   
   '// 鼠标单击按钮  按工具栏上图标正常功能
@@ -185,11 +196,13 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
     Tools.TextShape_ConvertToCurves
     
   ElseIf Abs(x - pos_x(10)) < 14 And Abs(y - pos_y(0)) < 14 Then
-    LEFT_BT.Visible = True
-    TOP_BT.Visible = True
+    '// 扩展工具栏
+    Me.Height = 30 + 45
     
   ElseIf Abs(x - pos_x(11)) < 14 And Abs(y - pos_y(0)) < 14 Then
+    '// 最小化
     Me.Width = 30
+    Me.Height = 30
     OPEN_UI_BIG.Left = 61
     UI.Visible = False
     LOGO.Visible = True
@@ -203,13 +216,6 @@ Private Sub X_EXIT_Click()
   Unload Me    ' 关闭
 End Sub
 
-Private Sub LEFT_BT_Click()
-  Tools.傻瓜火车排列
-End Sub
-
-Private Sub TOP_BT_Click()
- Tools.傻瓜阶梯排列
-End Sub
 
 Private Sub 调用多页合并工具()
   Dim value As Integer
@@ -329,11 +335,11 @@ Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift
   ElseIf Shift = fmCtrlMask Then
     Tools.Mark_CreateRectangle False
   Else
-    Tools.Create_Tolerance
+    Create_Tolerance
   End If
 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
@@ -342,7 +348,41 @@ Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
     Tools.Take_Apart_Character
     Me.Height = 30
   Else
-    Tools.Create_Tolerance
+    Create_Tolerance
+  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
+    MsgBox "简单一刀切，右键隐藏"
+    Me.Height = 30
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Single_Line
+  Else
+    ' Ctrl + 鼠标  空
+  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.傻瓜火车排列 3#
+  ElseIf Shift = fmCtrlMask Then
+    Tools.傻瓜火车排列 0#
+  Else
+    Tools.傻瓜火车排列 Set_Space_Width
+  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.傻瓜阶梯排列 3#
+  ElseIf Shift = fmCtrlMask Then
+    Tools.傻瓜阶梯排列 0#
+  Else
+    Tools.傻瓜阶梯排列 Set_Space_Width
   End If
 End Sub
 

module/API.bas

@@ -15,6 +15,27 @@ Public Function GetSet(s As String)
   
 End Function
 
+Public Function Create_Tolerance()
+  Dim text As String
+  If GlobalUserData.Exists("Tolerance", 1) Then
+    text = GlobalUserData("Tolerance", 1)
+  End If
+  text = InputBox("请输入容差值 0.1 --> 9.9", "容差值(mm)", text)
+  If text = "" Then Exit Function
+  GlobalUserData("Tolerance", 1) = text
+End Function
+
+Public Function Set_Space_Width() As Double
+  Dim text As String
+  If GlobalUserData.Exists("SpaceWidth", 1) Then
+    text = GlobalUserData("SpaceWidth", 1)
+  End If
+  text = InputBox("请输入间隔宽度值 0 --> 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
@@ -104,3 +125,15 @@ Function FindAllShapes() As ShapeRange
   Set FindAllShapes = srAll
 End Function
 
+' ************* 函数模块 ************* '
+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

module/CorelVBA窗口.bas

@@ -1,4 +1,4 @@
-Attribute VB_Name = "CorelVBA窗口"
+Attribute VB_Name = "CorelVBA´°¿Ú"
 Public Sub start()
   Toolbar.Show 0
 ' CorelVBA.show 0

module/Tools.bas

@@ -16,8 +16,9 @@ Public Function 分分合合()
 End Function
 
 
-Public Function 傻瓜火车排列()
+Public Function 傻瓜火车排列(space_width As Double)
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  ActiveDocument.Unit = cdrMillimeter
   Dim ssr As ShapeRange, s As Shape
   Dim cnt As Integer
   Set ssr = ActiveSelectionRange
@@ -35,7 +36,7 @@ Public Function 傻瓜火车排列()
     '' 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
     '' 改成顶对齐 2022-08-10
     ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).TopY
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + space_width, ssr(cnt - 1).TopY
     cnt = cnt + 1
   Next s
 
@@ -45,7 +46,7 @@ Public Function 傻瓜火车排列()
 End Function
 
 
-Public Function 傻瓜阶梯排列()
+Public Function 傻瓜阶梯排列(space_width As Double)
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   Dim ssr As ShapeRange, s As Shape
   Dim cnt As Integer
@@ -61,7 +62,7 @@ Public Function 傻瓜阶梯排列()
 
   ActiveDocument.ReferencePoint = cdrTopLeft
   For Each s In ssr
-    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - space_width
     cnt = cnt + 1
   Next s
 
@@ -331,16 +332,6 @@ Private Function mark_shape_expand(sh As Shape, tr As Double)
     s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
 End Function
 
-Public Function Create_Tolerance()
-  Dim text As String
-  If GlobalUserData.Exists("Tolerance", 1) Then
-    text = GlobalUserData("Tolerance", 1)
-  End If
-  text = InputBox("请输入容差值 0 --> 99", "容差值(mm)", text)
-  If text = "" Then Exit Function
-  GlobalUserData("Tolerance", 1) = text
-End Function
-
 Private Function mark_shape(sh As Shape)
   Dim s As Shape
   Dim x As Double, y As Double, w As Double, h As Double
@@ -448,9 +439,9 @@ ErrorHandler:
 End Function
 
 
-'''////  简单一刀切  识别群组 ////'''   ''' 本功能由群友宏瑞广告赞助发行 '''
+'''//// 简单一刀切 识别群组 ////''' ''' 本功能由群友宏瑞广告赞助发行 '''
 Public Function Single_Line()
-If 0 = ActiveSelectionRange.Count Then Exit Function
+  If 0 = ActiveSelectionRange.Count Then Exit Function
 '  On Error GoTo ErrorHandler
 '  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
@@ -461,11 +452,11 @@ If 0 = ActiveSelectionRange.Count Then Exit Function
 
   Dim ssr As ShapeRange
   Dim SrNew As New ShapeRange
-  Dim s As Shape, s1 As Shape, line As Shape
+  Dim s As Shape, s1 As Shape, line As Shape, line2 As Shape
   Dim cnt As Integer
   cnt = 1
   
-  
+
   If 1 = ActiveSelectionRange.Count Then
     Set ssr = ActiveSelectionRange(1).UngroupAllEx
   Else
@@ -487,9 +478,13 @@ If 0 = ActiveSelectionRange.Count Then Exit Function
 ' X4 不支持 ShapeRange.sort
 #End If
 
+'''  相交 Set line2 = line.Intersect(s, True, True)
+'''  判断相交  line.Curve.IntersectsWith(s.Curve)
+
   For Each s In ssr
     If cnt > 1 Then
-      Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY, s.LeftX, s.TopY - h)
+      s.ConvertToCurves
+      Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY, s.LeftX, s.TopY - s.SizeHeight)
       line.Outline.SetProperties Color:=cm(1)
       SrNew.Add line
     End If
@@ -507,3 +502,5 @@ ErrorHandler:
   Application.Optimization = False
   On Error Resume Next
 End Function
+
+

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

@@ -16,13 +16,13 @@ Sub start()
     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, "X", " ")
     Str = VBA.replace(Str, "*", " ")
     Str = VBA.replace(Str, vbNewLine, " ")
 
@@ -47,41 +47,43 @@ Sub start()
     ActiveDocument.EndCommandGroup
 End Sub
 
+'// 建立矩形 Width  x Height 单位 mm
 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
+  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)
+  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
 

module/拼版裁切线.bas

@@ -1,7 +1,7 @@
 Attribute VB_Name = "拼版裁切线"
 Type Coordinate
-    x As Double
-    y As Double
+  x As Double
+  y As Double
 End Type
 
 Sub Cut_lines()
@@ -72,127 +72,125 @@ End Sub
 
 '范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
 Private Function draw_line(dot As Coordinate, border As Variant)
-    radius = border(6): Bleed = border(7):  Line_len = border(8)
-    Dim line As Shape
-
-    If Abs(dot.y - border(3)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, border(3) + Bleed, dot.x, border(3) + (Line_len + Bleed))
-        set_line_color line
-    ElseIf Abs(dot.y - border(2)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, border(2) - Bleed, dot.x, border(2) - (Line_len + Bleed))
-        set_line_color line
-    End If
-    
-    If Abs(dot.x - border(1)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.y, border(1) + (Line_len + Bleed), dot.y)
-        set_line_color line
-    ElseIf Abs(dot.x - border(0)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.y, border(0) - (Line_len + Bleed), dot.y)
-        set_line_color line
-    End If
+  radius = border(6): Bleed = border(7):  Line_len = border(8)
+  Dim line As Shape
+
+  If Abs(dot.y - border(3)) < radius Then
+    Set line = ActiveLayer.CreateLineSegment(dot.x, border(3) + Bleed, dot.x, border(3) + (Line_len + Bleed))
+    set_line_color line
+  ElseIf Abs(dot.y - border(2)) < radius Then
+    Set line = ActiveLayer.CreateLineSegment(dot.x, border(2) - Bleed, dot.x, border(2) - (Line_len + Bleed))
+    set_line_color line
+  End If
+  
+  If Abs(dot.x - border(1)) < radius Then
+    Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.y, border(1) + (Line_len + Bleed), dot.y)
+    set_line_color line
+  ElseIf Abs(dot.x - border(0)) < radius Then
+    Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.y, border(0) - (Line_len + Bleed), dot.y)
+    set_line_color line
+  End If
 
 End Function
 
 '// 旧版本
 Private Function draw_line_按点基准(dot As Coordinate, border As Variant)
-    Bleed = 2:  Line_len = 3:  radius = border(6)
-    Dim line As Shape
-
-    If Abs(dot.y - border(3)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y + Bleed, dot.x, dot.y + (Line_len + Bleed))
-        set_line_color line
-    ElseIf Abs(dot.y - border(2)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y - Bleed, dot.x, dot.y - (Line_len + Bleed))
-        set_line_color line
-    End If
-    
-    If Abs(dot.x - border(1)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x + Bleed, dot.y, dot.x + (Line_len + Bleed), dot.y)
-        set_line_color line
-    ElseIf Abs(dot.x - border(0)) < radius Then
-        Set line = ActiveLayer.CreateLineSegment(dot.x - Bleed, dot.y, dot.x - (Line_len + Bleed), dot.y)
-        set_line_color line
-    End If
+  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)
+   '// 设置轮廓线注册色
+  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)
+  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, "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)
+  Dim s1 As Shape
+  Dim x As Double, y As Double
   
-      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
+  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
-      
-      
-      '// 建立矩形 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
+     
+    '// 建立矩形 Width  x Height 单位 mm
+    Set s1 = ActiveLayer.CreateRectangle(0, 0, x, y)
     
-
-    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
+    '// 填充颜色无，轮廓颜色 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
+  MsgBox "记事本输入数字,示例: 50x50 4x3 ,复制到剪贴板再运行工具!"
+  On Error Resume Next
 End Sub
 
 

module/智能查找.bas

@@ -1,22 +1,22 @@
 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
+  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
 
 
@@ -60,9 +60,9 @@ Private Sub get_little_points()
   Application.Refresh
   Exit Sub
 ErrorHandler:
-     MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
-     Application.Optimization = False
-    On Error Resume Next
+  MsgBox "选择水洗标要加点部分，然后点击【加点工具】按钮!"
+  Application.Optimization = False
+  On Error Resume Next
 End Sub
 
 Sub 文字转曲()

module/智能群组和查找.bas

@@ -4,9 +4,10 @@ Sub 剪贴板物件替换()
 End Sub
 
 Public Sub 智能群组()
-If 0 = ActiveSelectionRange.Count Then Exit Sub
+  If 0 = ActiveSelectionRange.Count Then Exit Sub
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
   ActiveDocument.ReferencePoint = cdrBottomLeft
   ActiveDocument.Unit = cdrMillimeter
   
@@ -27,7 +28,8 @@ If 0 = ActiveSelectionRange.Count Then Exit Sub
     '// 轴线 创建轮廓处理
     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#)
+      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
@@ -53,7 +55,7 @@ If 0 = ActiveSelectionRange.Count Then Exit Sub
 
   ActiveDocument.EndCommandGroup
   Application.Optimization = False
-  ActiveWindow.Refresh:    Application.Refresh
+  ActiveWindow.Refresh:   Application.Refresh
 Exit Sub
 
 ErrorHandler:
@@ -63,38 +65,39 @@ ErrorHandler:
 
 End Sub
 
-
+' 智能群组_V1 第一版，储备示例代码
 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
+  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
+  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
+  '// 代码操作结束恢复窗口刷新
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
 Exit Function
 ErrorHandler:
-    Application.Optimization = False
-    MsgBox "请先选择一些物件来确定群组范围!"
-    On Error Resume Next
+  Application.Optimization = False
+  MsgBox "请先选择一些物件来确定群组范围!"
+  On Error Resume Next
 End Function
 

module/自动中线色阶条.bas

@@ -102,44 +102,44 @@ Private Function set_line_color(line As Shape)
 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)
+  ' 添加页面框线
+  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
+  ' 在页面四边放置中线
+  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
+  ' 在页面四角放置套准标记线
+  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)
@@ -169,44 +169,44 @@ Private Function put_ColorStrip(sh As Shape)
 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)
+  ' 添加文字 页面大小和文件名
+  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
+  ' 在页面四角放置套准标记线  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
+  ' 在页面四边放置中线 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)
@@ -236,18 +236,18 @@ Private Function put_ColorStrip(sh As Shape)
 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
+  ' 添加文字 页面大小
+  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
 
 
-
+' 自动中线 For 黑白产品版
 Sub Auto_ColorMark_K()
   If 0 = ActiveSelectionRange.Count Then Exit Sub
   On Error GoTo ErrorHandler

module/裁切线.bas

@@ -19,31 +19,31 @@ If 0 = ActiveSelectionRange.Count Then Exit Sub
   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 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 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 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))
+    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 Outline_Width
-      ActiveSelection.Outline.SetProperties Color:=CreateRegistrationColor
+    '// 选中裁切线 群组 设置线宽和注册色
+    ActiveDocument.AddToSelection s2, s3, s4, s5, s6, s7, s8, s9
+    ActiveSelection.Group
+    ActiveSelection.Outline.SetProperties Outline_Width
+    ActiveSelection.Outline.SetProperties Color:=CreateRegistrationColor
   
   Next Target
 
@@ -78,38 +78,38 @@ Sub SelectLine_to_Cropline()
   '// 遍历选择的线条
   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
+    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 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 Outline_Width
-      line.Outline.SetProperties Color:=CreateRegistrationColor
+   '// 判断横线(高度小于宽度)，在页面左边还是右边
+   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 Outline_Width
+    line.Outline.SetProperties Color:=CreateRegistrationColor
   Next s
   
   ActiveDocument.EndCommandGroup