代码更新: 增加一步撤销,裁切线支持多选择,拼版自动计算个数,发掘裁切线爬虫功能

ClipboardRectangle.bas

@@ -31,6 +31,7 @@ Sub start()
     Loop
     arr = Split(Str)
     
+    ActiveDocument.BeginCommandGroup  '一步撤消'
     Dim x As Double
     Dim y As Double
     For n = LBound(arr) To UBound(arr) - 1 Step 2
@@ -43,6 +44,7 @@ Sub start()
             O_O.x = O_O.x + x + 30
         End If
     Next
+    ActiveDocument.EndCommandGroup
 End Sub
 
 Private Function Rectangle(Width As Double, Height As Double)

SelectLine_to_Cropline.bas

@@ -5,6 +5,8 @@ Sub SelectLine_to_Cropline()
     Application.Optimization = True
     ActiveDocument.Unit = cdrMillimeter
     
+    ActiveDocument.BeginCommandGroup  '一步撤消'
+    
     '// 获得页面中心点 x,y
     px = ActiveDocument.Pages.First.CenterX
     py = ActiveDocument.Pages.First.CenterY
@@ -28,7 +30,7 @@ Sub SelectLine_to_Cropline()
         sh = s.SizeHeight
        
        '// 判断横线(高度小于宽度)，在页面左边还是右边
-       If sh < sw Then
+       If sh <= sw Then
         s.Delete
         If cx < px Then
             Set line = ActiveLayer.CreateLineSegment(0, cy, 0 + line_len, cy)
@@ -51,9 +53,9 @@ Sub SelectLine_to_Cropline()
         line.Outline.SetProperties Color:=CreateRegistrationColor
     Next s
     
+    ActiveDocument.EndCommandGroup
     '// 代码操作结束恢复窗口刷新
     Application.Optimization = False
     ActiveWindow.Refresh
     Application.Refresh
 End Sub
-

arrange.bas

@@ -4,8 +4,8 @@ Sub arrange()
     ActiveDocument.Unit = cdrMillimeter
     row = 3     ' 拼版 3 x 4
     List = 4
-    sp = 0       '间隔 0mm
-    
+    sp = 0       '间隔 0mm 
+
     Dim Str, arr, n
     Str = GetClipBoardString
 
@@ -16,20 +16,19 @@ Sub arrange()
     Str = VBA.Replace(Str, Chr(13), " ")
     Str = VBA.Replace(Str, Chr(9), " ")
     
-    Do While InStr(Str, "  ") '多个空格换成一个空格
+    Do While InStr(Str, "  ")    '多个空格换成一个空格
         Str = VBA.Replace(Str, "  ", " ")
     Loop
     
     arr = Split(Str)
 
-    Dim x As Double
-    Dim y As Double
-    x = Val(arr(0))
-    y = Val(arr(1))
-    
+    Dim x As Double, y As Double
+    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))     ' 拼版 3 x 4
-    List = Val(arr(3))
+    row = Val(arr(2)):  List = Val(arr(3))
         If UBound(arr) > 3 Then
             sp = Val(arr(4))       '间隔
         End If
@@ -44,9 +43,8 @@ Sub arrange()
     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 = x
-    sh = y
-    
+    sw = x:  sh = y
+
     '// StepAndRepeat 方法在范围内创建多个形状副本
     Dim dup1 As ShapeRange
     Set dup1 = s1.StepAndRepeat(row - 1, sw + sp, 0#)

cropline.bas

@@ -1,43 +1,52 @@
-Attribute VB_Name = "裁切线"
+' Attribute VB_Name = "裁切线"
 Sub start()
+    '// 代码运行时关闭窗口刷新
+    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
-    Set s1 = ActiveSelection
-    
-    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
+    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

cut_lines.bas

@@ -3,9 +3,10 @@ Type Coordinate
     y As Double
 End Type
 
-Sub ShapesRange()
+Sub Cut_lines()
 '// 代码运行时关闭窗口刷新
     Application.Optimization = True
+    ActiveDocument.BeginCommandGroup  '一步撤消'
     ActiveDocument.Unit = cdrMillimeter
     Dim OrigSelection As ShapeRange
     Set OrigSelection = ActiveSelectionRange
@@ -45,6 +46,7 @@ Sub ShapesRange()
         End If
     Next Target
   
+    ActiveDocument.EndCommandGroup
     '// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
     ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
     ActiveSelection.Group