1
1

cut_lines.bas 4.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117
  1. Type Coordinate
  2. x As Double
  3. y As Double
  4. End Type
  5. Sub Cut_lines()
  6. If 0 = ActiveSelectionRange.Count Then Exit Sub
  7. '// 代码运行时关闭窗口刷新
  8. Application.Optimization = True
  9. ActiveDocument.BeginCommandGroup '一步撤消'
  10. ActiveDocument.Unit = cdrMillimeter
  11. Dim OrigSelection As ShapeRange
  12. Set OrigSelection = ActiveSelectionRange
  13. Dim s1 As Shape, sbd As Shape
  14. Dim dot As Coordinate
  15. Dim arr As Variant, border As Variant
  16. ' 当前选择物件的范围边界
  17. set_lx = OrigSelection.LeftX: set_rx = OrigSelection.RightX
  18. set_by = OrigSelection.BottomY: set_ty = OrigSelection.TopY
  19. set_cx = OrigSelection.CenterX: set_cy = OrigSelection.CenterY
  20. radius = 8: border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius)
  21. ' 创建边界矩形,用来添加角线
  22. Set sbd = ActiveLayer.CreateRectangle(set_lx, set_by, set_rx, set_ty)
  23. OrigSelection.Add sbd
  24. For Each Target In OrigSelection
  25. Set s1 = Target
  26. lx = s1.LeftX: rx = s1.RightX
  27. by = s1.BottomY: ty = s1.TopY
  28. cx = s1.CenterX: cy = s1.CenterY
  29. '// 范围边界物件判断
  30. If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - by) _
  31. < radius Or Abs(set_ty - ty) < radius Then
  32. arr = Array(lx, by, rx, by, lx, ty, rx, ty) '// 物件左下-右下-左上-右上 四个顶点坐标数组
  33. For i = 0 To 3
  34. dot.x = arr(2 * i)
  35. dot.y = arr(2 * i + 1)
  36. '// 范围边界坐标点判断
  37. If Abs(set_lx - dot.x) < radius Or Abs(set_rx - dot.x) < radius _
  38. Or Abs(set_by - dot.y) < radius Or Abs(set_ty - dot.y) < radius Then
  39. draw_line dot, border '// 以坐标点和范围边界画裁切线
  40. End If
  41. Next i
  42. End If
  43. Next Target
  44. sbd.Delete '删除边界矩形
  45. '// 使用CQL 颜色标志查找,然后群组统一设置线宽和注册色
  46. ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
  47. ActiveSelection.Group
  48. ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
  49. ActiveDocument.EndCommandGroup
  50. '// 代码操作结束恢复窗口刷新
  51. Application.Optimization = False
  52. ActiveWindow.Refresh
  53. Application.Refresh
  54. End Sub
  55. '范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius)
  56. Private Function draw_line(dot As Coordinate, border As Variant)
  57. Bleed = 2: line_len = 3: radius = border(6)
  58. Dim line As Shape
  59. If Abs(dot.y - border(3)) < radius Then
  60. Set line = ActiveLayer.CreateLineSegment(dot.x, border(3) + Bleed, dot.x, border(3) + (line_len + Bleed))
  61. set_line_color line
  62. ElseIf Abs(dot.y - border(2)) < radius Then
  63. Set line = ActiveLayer.CreateLineSegment(dot.x, border(2) - Bleed, dot.x, border(2) - (line_len + Bleed))
  64. set_line_color line
  65. End If
  66. If Abs(dot.x - border(1)) < radius Then
  67. Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.y, border(1) + (line_len + Bleed), dot.y)
  68. set_line_color line
  69. ElseIf Abs(dot.x - border(0)) < radius Then
  70. Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.y, border(0) - (line_len + Bleed), dot.y)
  71. set_line_color line
  72. End If
  73. End Function
  74. '// 旧版本
  75. Private Function draw_line_按点基准(dot As Coordinate, border As Variant)
  76. Bleed = 2: line_len = 3: radius = border(6)
  77. Dim line As Shape
  78. If Abs(dot.y - border(3)) < radius Then
  79. Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y + Bleed, dot.x, dot.y + (line_len + Bleed))
  80. set_line_color line
  81. ElseIf Abs(dot.y - border(2)) < radius Then
  82. Set line = ActiveLayer.CreateLineSegment(dot.x, dot.y - Bleed, dot.x, dot.y - (line_len + Bleed))
  83. set_line_color line
  84. End If
  85. If Abs(dot.x - border(1)) < radius Then
  86. Set line = ActiveLayer.CreateLineSegment(dot.x + Bleed, dot.y, dot.x + (line_len + Bleed), dot.y)
  87. set_line_color line
  88. ElseIf Abs(dot.x - border(0)) < radius Then
  89. Set line = ActiveLayer.CreateLineSegment(dot.x - Bleed, dot.y, dot.x - (line_len + Bleed), dot.y)
  90. set_line_color line
  91. End If
  92. End Function
  93. Private Function set_line_color(line As Shape)
  94. '// 设置线宽和注册色
  95. line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
  96. End Function