1
1

CutLines.bas 9.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302
  1. Attribute VB_Name = "CutLines"
  2. '// This is free and unencumbered software released into the public domain.
  3. '// For more information, please refer to https://github.com/hongwenjun
  4. '// Attribute VB_Name = "裁切线" CutLines 2023.6.9
  5. '// 选中多个物件批量制作四角裁切线
  6. Public Function Batch_CutLines()
  7. If 0 = ActiveSelectionRange.Count Then Exit Function
  8. API.BeginOpt
  9. Bleed = API.GetSet("Bleed")
  10. Line_len = API.GetSet("Line_len")
  11. Outline_Width = API.GetSet("Outline_Width")
  12. '// 定义当前选择物件 分别获得 左右下上中心坐标(x,y)和尺寸信息
  13. Dim s1 As Shape, OrigSelection As ShapeRange, sr As New ShapeRange
  14. Set OrigSelection = ActiveSelectionRange
  15. For Each s1 In OrigSelection
  16. lx = s1.LeftX: rx = s1.RightX
  17. by = s1.BottomY: ty = s1.TopY
  18. cx = s1.CenterX: cy = s1.CenterY
  19. sw = s1.SizeWidth: sh = s1.SizeHeight
  20. '// 添加裁切线,分别左下-右下-左上-右上
  21. Dim s2, s3, s4, s5, s6, s7, s8, s9 As Shape
  22. Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, by, lx - (Bleed + Line_len), by)
  23. Set s3 = ActiveLayer.CreateLineSegment(lx, by - Bleed, lx, by - (Bleed + Line_len))
  24. Set s4 = ActiveLayer.CreateLineSegment(rx + Bleed, by, rx + (Bleed + Line_len), by)
  25. Set s5 = ActiveLayer.CreateLineSegment(rx, by - Bleed, rx, by - (Bleed + Line_len))
  26. Set s6 = ActiveLayer.CreateLineSegment(lx - Bleed, ty, lx - (Bleed + Line_len), ty)
  27. Set s7 = ActiveLayer.CreateLineSegment(lx, ty + Bleed, lx, ty + (Bleed + Line_len))
  28. Set s8 = ActiveLayer.CreateLineSegment(rx + Bleed, ty, rx + (Bleed + Line_len), ty)
  29. Set s9 = ActiveLayer.CreateLineSegment(rx, ty + Bleed, rx, ty + (Bleed + Line_len))
  30. '// 选中裁切线 群组 设置线宽和注册色
  31. ActiveDocument.AddToSelection s2, s3, s4, s5, s6, s7, s8, s9
  32. ActiveSelection.Group
  33. sr.Add ActiveSelection
  34. Next s1
  35. '// 设置线宽和颜色,再选择
  36. sr.SetOutlineProperties Outline_Width
  37. sr.SetOutlineProperties Color:=CreateRegistrationColor
  38. sr.AddToSelection
  39. API.EndOpt
  40. End Function
  41. '// 标注尺寸标记线
  42. Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAlignTop, Optional ByVal mirror As Boolean = False)
  43. If 0 = ActiveSelectionRange.Count Then Exit Function
  44. API.BeginOpt
  45. Bleed = API.GetSet("Bleed")
  46. Line_len = API.GetSet("Line_len")
  47. Outline_Width = API.GetSet("Outline_Width")
  48. '// 定义当前选择物件 分别获得 左右下上中心坐标(x,y)和尺寸信息
  49. Dim s As Shape, s1 As Shape, OrigSelection As ShapeRange, sr As New ShapeRange
  50. Set OrigSelection = ActiveSelectionRange
  51. For Each s1 In OrigSelection
  52. lx = s1.LeftX: rx = s1.RightX
  53. by = s1.BottomY: ty = s1.TopY
  54. '// 添加使用 左-上 标注尺寸标记线
  55. Dim s2, s6, s7, s8, s9 As Shape
  56. If mark = cdrAlignTop Then
  57. Set s7 = ActiveLayer.CreateLineSegment(lx, ty + Bleed, lx, ty + (Bleed + Line_len))
  58. Set s9 = ActiveLayer.CreateLineSegment(rx, ty + Bleed, rx, ty + (Bleed + Line_len))
  59. sr.Add s7: sr.Add s9
  60. Else
  61. Set s2 = ActiveLayer.CreateLineSegment(lx - Bleed, by, lx - (Bleed + Line_len), by)
  62. Set s6 = ActiveLayer.CreateLineSegment(lx - Bleed, ty, lx - (Bleed + Line_len), ty)
  63. sr.Add s2: sr.Add s6
  64. End If
  65. Next s1
  66. '// 获得页面中心点 x,y
  67. ' px = ActiveDocument.Pages.First.CenterX
  68. ' py = ActiveDocument.Pages.First.CenterY
  69. '// 物件范围边界
  70. px = OrigSelection.LeftX
  71. py = OrigSelection.TopY
  72. mpx = OrigSelection.RightX
  73. mpy = OrigSelection.BottomY
  74. '// 页面边缘对齐
  75. For Each s In sr
  76. s.name = "DMKLine"
  77. If mark = cdrAlignTop Then
  78. s.TopY = py + Line_len + Bleed
  79. Else
  80. s.LeftX = px - Line_len - Bleed
  81. End If
  82. Next s
  83. '// 简单删除重复
  84. RemoveDuplicates sr
  85. '// 设置线宽和颜色,再选择
  86. sr.SetOutlineProperties Outline_Width
  87. sr.SetOutlineProperties Color:=CreateCMYKColor(80, 40, 0, 20)
  88. sr.AddToSelection
  89. If mirror Then
  90. If mark = cdrAlignTop Then
  91. sr.BottomY = mpy - Line_len - Bleed
  92. Else
  93. sr.RightX = mpx + Line_len + Bleed
  94. End If
  95. End If
  96. API.EndOpt
  97. End Function
  98. '// 简单删除重复线和物件算法算法
  99. Public Function RemoveDuplicates(sr As ShapeRange)
  100. Dim s As Shape, cnt As Integer, rms As New ShapeRange
  101. cnt = 1
  102. #If VBA7 Then
  103. sr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
  104. #Else
  105. Set sr = X4_Sort_ShapeRange(sr, topWt_left)
  106. #End If
  107. For Each s In sr
  108. If cnt > 1 Then
  109. If Check_duplicate(sr(cnt - 1), sr(cnt)) Then rms.Add sr(cnt)
  110. End If
  111. cnt = cnt + 1
  112. Next s
  113. sr.RemoveRange rms
  114. rms.Delete
  115. End Function
  116. '// 检查重复算法
  117. Private Function Check_duplicate(s1 As Shape, s2 As Shape) As Boolean
  118. Check_duplicate = False
  119. Jitter = 0.3
  120. X = Abs(s1.CenterX - s2.CenterX)
  121. Y = Abs(s1.CenterY - s2.CenterY)
  122. w = Abs(s1.SizeWidth - s2.SizeWidth)
  123. h = Abs(s1.SizeHeight - s2.SizeHeight)
  124. If X < Jitter And Y < Jitter And w < Jitter And h < Jitter Then
  125. Check_duplicate = True
  126. End If
  127. End Function
  128. '// 单线条转裁切线 - 放置到页面四边
  129. Public Function SelectLine_to_Cropline()
  130. If 0 = ActiveSelectionRange.Count Then Exit Function
  131. API.BeginOpt
  132. '// 获得页面中心点 x,y , 设置新绘制线属性
  133. px = ActiveDocument.Pages.First.CenterX
  134. py = ActiveDocument.Pages.First.CenterY
  135. Bleed = API.GetSet("Bleed")
  136. Line_len = API.GetSet("Line_len")
  137. Outline_Width = API.GetSet("Outline_Width")
  138. Dim s As Shape, line As Shape
  139. Dim sr_line As New ShapeRange
  140. '// 遍历选择的线条
  141. For Each s In ActiveSelection.Shapes
  142. cx = s.CenterX: cy = s.CenterY
  143. sw = s.SizeWidth: sh = s.SizeHeight
  144. '// 判断横线(高度小于宽度),在页面左边还是右边
  145. If sh <= sw Then
  146. s.Delete
  147. If cx < px Then
  148. Set line = ActiveLayer.CreateLineSegment(0, cy, 0 + Line_len, cy)
  149. Else
  150. Set line = ActiveLayer.CreateLineSegment(px * 2, cy, px * 2 - Line_len, cy)
  151. End If
  152. End If
  153. '// 判断竖线(高度大于宽度),在页面下边还是上边
  154. If sh > sw Then
  155. s.Delete
  156. If cy < py Then
  157. Set line = ActiveLayer.CreateLineSegment(cx, 0, cx, 0 + Line_len)
  158. Else
  159. Set line = ActiveLayer.CreateLineSegment(cx, py * 2, cx, py * 2 - Line_len)
  160. End If
  161. End If
  162. sr_line.Add line
  163. Next s
  164. RemoveDuplicates sr_line
  165. sr_line.SetOutlineProperties Outline_Width, Color:=CreateRegistrationColor
  166. sr_line.AddToSelection
  167. API.EndOpt
  168. End Function
  169. '// 拼版裁切线
  170. Public Function Draw_Lines()
  171. If 0 = ActiveSelectionRange.Count Then Exit Function
  172. API.BeginOpt
  173. Dim OrigSelection As ShapeRange, sr As ShapeRange
  174. Set OrigSelection = ActiveSelectionRange
  175. Dim s1 As Shape, sbd As Shape
  176. Dim dot As Coordinate
  177. Dim arr As Variant, border As Variant
  178. ' 当前选择物件的范围边界
  179. set_lx = OrigSelection.LeftX: set_rx = OrigSelection.RightX
  180. set_by = OrigSelection.BottomY: set_ty = OrigSelection.TopY
  181. set_cx = OrigSelection.CenterX: set_cy = OrigSelection.CenterY
  182. radius = 8
  183. Bleed = API.GetSet("Bleed")
  184. Line_len = API.GetSet("Line_len")
  185. Outline_Width = API.GetSet("Outline_Width")
  186. border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
  187. ' 创建边界矩形,用来添加角线
  188. Set sbd = ActiveLayer.CreateRectangle(set_lx, set_by, set_rx, set_ty)
  189. OrigSelection.Add sbd
  190. For Each Target In OrigSelection
  191. Set s1 = Target
  192. lx = s1.LeftX: rx = s1.RightX
  193. by = s1.BottomY: ty = s1.TopY
  194. cx = s1.CenterX: cy = s1.CenterY
  195. '// 范围边界物件判断
  196. If Abs(set_lx - lx) < radius Or Abs(set_rx - rx) < radius Or Abs(set_by - by) _
  197. < radius Or Abs(set_ty - ty) < radius Then
  198. arr = Array(lx, by, rx, by, lx, ty, rx, ty) '// 物件左下-右下-左上-右上 四个顶点坐标数组
  199. For i = 0 To 3
  200. dot.X = arr(2 * i)
  201. dot.Y = arr(2 * i + 1)
  202. '// 范围边界坐标点判断
  203. If Abs(set_lx - dot.X) < radius Or Abs(set_rx - dot.X) < radius _
  204. Or Abs(set_by - dot.Y) < radius Or Abs(set_ty - dot.Y) < radius Then
  205. draw_line dot, border '// 以坐标点和范围边界画裁切线
  206. End If
  207. Next i
  208. End If
  209. Next Target
  210. sbd.Delete '删除边界矩形
  211. '// 使用CQL 颜色标志查
  212. Set sr = ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))")
  213. '// 简单删除重复
  214. RemoveDuplicates sr
  215. '// 设置线宽和颜色,再选择
  216. sr.SetOutlineProperties Outline_Width, Color:=CreateRegistrationColor
  217. sr.Group
  218. sr.AddRange OrigSelection
  219. sr.AddToSelection
  220. API.EndOpt
  221. End Function
  222. '范围边界 border = Array(set_lx, set_rx, set_by, set_ty, set_cx, set_cy, radius, Bleed, Line_len)
  223. Private Function draw_line(dot As Coordinate, border As Variant)
  224. radius = border(6): Bleed = border(7): Line_len = border(8)
  225. Dim line As Shape
  226. If Abs(dot.Y - border(3)) < radius Then
  227. Set line = ActiveLayer.CreateLineSegment(dot.X, border(3) + Bleed, dot.X, border(3) + (Line_len + Bleed))
  228. set_line_color line
  229. ElseIf Abs(dot.Y - border(2)) < radius Then
  230. Set line = ActiveLayer.CreateLineSegment(dot.X, border(2) - Bleed, dot.X, border(2) - (Line_len + Bleed))
  231. set_line_color line
  232. End If
  233. If Abs(dot.X - border(1)) < radius Then
  234. Set line = ActiveLayer.CreateLineSegment(border(1) + Bleed, dot.Y, border(1) + (Line_len + Bleed), dot.Y)
  235. set_line_color line
  236. ElseIf Abs(dot.X - border(0)) < radius Then
  237. Set line = ActiveLayer.CreateLineSegment(border(0) - Bleed, dot.Y, border(0) - (Line_len + Bleed), dot.Y)
  238. set_line_color line
  239. End If
  240. End Function
  241. Private Function set_line_color(line As Shape)
  242. '// 设置轮廓线注册色
  243. line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
  244. End Function