1
1

Container.bas 4.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189
  1. Attribute VB_Name = "Container"
  2. ' ① 标记容器盒子
  3. Public Function SetBoxName()
  4. API.BeginOpt "标记容器盒子"
  5. Dim box As ShapeRange, s As Shape
  6. Set box = ActiveSelectionRange
  7. ' 设置物件名字,以供CQL查询
  8. For Each s In box
  9. s.Name = "Container"
  10. Next s
  11. API.EndOpt
  12. MsgBox "标记容器盒子" & vbNewLine & "名字: Container"
  13. End Function
  14. ' 图片批量置入容器
  15. Public Sub Batch_ToPowerClip()
  16. API.BeginOpt "批量置入容器"
  17. Dim s As Shape, ssr As ShapeRange, box As ShapeRange
  18. Set ssr = Smart_Group(0.5) ' 智能群组容差 0.5mm
  19. For Each s In ssr
  20. Image_ToPowerClip s
  21. Next s
  22. API.EndOpt
  23. End Sub
  24. ' 图片置入容器,基本函数
  25. Public Function Image_ToPowerClip(arg As Shape)
  26. Dim box As ShapeRange
  27. Dim ssr As New ShapeRange, rmsr As New ShapeRange
  28. Set ssr = arg.UngroupEx
  29. ' CQL查找容器盒物件
  30. Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
  31. ssr.RemoveRange box
  32. If box.Count = 0 Then Exit Function
  33. box.SetOutlineProperties Width:=0, Color:=Nothing
  34. ssr.AddToPowerClip box(1), 0
  35. box(1).Name = "powerclip_ok"
  36. End Function
  37. ' 图片OneKey置入容器
  38. Public Sub OneKey_ToPowerClip()
  39. API.BeginOpt "图片OneKey置入容器"
  40. Dim s As Shape, ssr As ShapeRange, box As ShapeRange
  41. ' 标记容器,设置透明
  42. Set box = ActiveSelectionRange
  43. For Each s In box
  44. If s.Type <> cdrBitmapShape Then s.Name = "Container"
  45. Next s
  46. Set ssr = Smart_Group(0.5) ' 智能群组容差 0.5mm
  47. Application.Optimization = True
  48. For Each s In ssr
  49. Image_ToPowerClip s
  50. Next s
  51. API.EndOpt
  52. End Sub
  53. ' ② 删除容器盒子边界外面的物件 ③④
  54. Public Function Remove_OutsideBox()
  55. Dim s As Shape
  56. Dim ssr As ShapeRange, box As ShapeRange
  57. Dim rmsr As New ShapeRange
  58. Dim x As Double, Y As Double
  59. Set ssr = ActiveSelectionRange
  60. ' CQL查找容器盒物件
  61. Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
  62. ssr.RemoveRange box
  63. If box.Count = 0 Then Exit Function
  64. ActiveDocument.Unit = cdrMillimeter
  65. For Each s In ssr
  66. x = s.CenterX: Y = s.CenterY
  67. If box(1).IsOnShape(x, Y) = cdrOutsideShape Then rmsr.Add s
  68. Next s
  69. rmsr.Delete
  70. End Function
  71. Public Function Remove_OnMargin()
  72. Dim s As Shape
  73. Dim ssr As ShapeRange, box As ShapeRange
  74. Dim rmsr As New ShapeRange
  75. Dim x As Double, Y As Double
  76. Set ssr = ActiveSelectionRange
  77. ' CQL查找容器盒物件
  78. Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
  79. ssr.RemoveRange box
  80. If box.Count = 0 Then Exit Function
  81. ActiveDocument.Unit = cdrMillimeter
  82. For Each s In ssr
  83. x = s.CenterX: Y = s.CenterY
  84. If box(1).IsOnShape(x, Y) = cdrOnMarginOfShape Then rmsr.Add s
  85. Next s
  86. rmsr.Delete
  87. End Function
  88. Public Function Select_OutsideBox()
  89. Dim s As Shape
  90. Dim ssr As ShapeRange, box As ShapeRange
  91. Dim SelSr As New ShapeRange
  92. Dim x As Double, Y As Double, radius
  93. Set ssr = ActiveSelectionRange
  94. ' CQL查找容器盒物件
  95. Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
  96. ssr.RemoveRange box
  97. If box.Count = 0 Then Exit Function
  98. ActiveDocument.Unit = cdrMillimeter
  99. For Each s In ssr
  100. x = s.CenterX: Y = s.CenterY
  101. radius = s.SizeWidth / 2
  102. If box(1).IsOnShape(x, Y, radius) = cdrOutsideShape Then SelSr.Add s
  103. Next s
  104. ActiveDocument.ClearSelection
  105. SelSr.AddToSelection
  106. End Function
  107. Public Function Select_OnMargin()
  108. Dim s As Shape
  109. Dim ssr As ShapeRange, box As ShapeRange
  110. Dim SelSr As New ShapeRange
  111. Dim x As Double, Y As Double, radius
  112. Set ssr = ActiveSelectionRange
  113. ' CQL查找容器盒物件
  114. Set box = ssr.Shapes.FindShapes(Query:="@name ='Container'")
  115. ssr.RemoveRange box
  116. If box.Count = 0 Then Exit Function
  117. ActiveDocument.Unit = cdrMillimeter
  118. For Each s In ssr
  119. x = s.CenterX: Y = s.CenterY
  120. radius = s.SizeWidth / 2
  121. If box(1).IsOnShape(x, Y, radius) = cdrOnMarginOfShape Then SelSr.Add s
  122. Next s
  123. ActiveDocument.ClearSelection
  124. SelSr.AddToSelection
  125. End Function
  126. ' 这个子程序遍历对象,调用解散物件和居中
  127. Public Sub Batch_Center()
  128. Dim s As Shape, ssr As ShapeRange
  129. Set ssr = Smart_Group
  130. For Each s In ssr
  131. Ungroup_Center s
  132. Next s
  133. End Sub
  134. ' 以下函数,解散物件,以面积排序居中
  135. Private Function Ungroup_Center(os As Shape)
  136. Set grp = os.UngroupEx
  137. grp.Sort "@shape1.Width * @shape1.Height> @shape2.Width * @shape2.Height"
  138. cx = grp(1).CenterX
  139. cy = grp(1).CenterY
  140. For Each s In grp
  141. s.CenterX = cx
  142. s.CenterY = cy
  143. Next s
  144. End Function