1
1

Batch_Center.bas 2.6 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586
  1. Attribute VB_Name = "Batch_Center"
  2. Private Function Smart_Group() As ShapeRange
  3. If 0 = ActiveSelectionRange.Count Then Exit Function
  4. On Error GoTo ErrorHandler
  5. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  6. ActiveDocument.ReferencePoint = cdrBottomLeft
  7. ActiveDocument.Unit = cdrMillimeter
  8. Dim OrigSelection As ShapeRange, sr As New ShapeRange
  9. Dim s1 As Shape, sh As Shape, s As Shape
  10. Dim x As Double, y As Double, w As Double, h As Double
  11. Dim eff1 As Effect
  12. Set OrigSelection = ActiveSelectionRange
  13. '// 遍历物件画矩形
  14. For Each sh In OrigSelection
  15. sh.GetBoundingBox x, y, w, h
  16. If w * h > 4 Then
  17. Set s = ActiveLayer.CreateRectangle2(x, y, w, h)
  18. sr.Add s
  19. '// 轴线 创建轮廓处理
  20. ElseIf w * h < 0.3 Then
  21. ' Debug.Print w * h
  22. 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#)
  23. eff1.Separate
  24. End If
  25. Next sh
  26. '// 查找轴线轮廓
  27. ActivePage.Shapes.FindShapes(Query:="@Outline.Color=RGB(26, 22, 35)").CreateSelection
  28. ActivePage.Shapes.FindShapes(Query:="@fill.Color=RGB(26, 22, 35)").AddToSelection
  29. For Each sh In ActiveSelection.Shapes
  30. sr.Add sh
  31. Next sh
  32. '// 新矩形寻找边界,散开,删除刚才画的新矩形
  33. Set s1 = sr.CustomCommand("Boundary", "CreateBoundary")
  34. Set brk1 = s1.BreakApartEx
  35. sr.Delete
  36. '// 矩形边界智能群组,删除矩形
  37. Dim retsr As New ShapeRange
  38. For Each s In brk1
  39. Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
  40. retsr.Add sh.Shapes.All.Group
  41. s.Delete
  42. Next
  43. Set Smart_Group = retsr
  44. ActiveDocument.EndCommandGroup
  45. Application.Optimization = False
  46. ActiveWindow.Refresh: Application.Refresh
  47. Exit Function
  48. ErrorHandler:
  49. Application.Optimization = False
  50. MsgBox "请先选择一些物件来确定群组范围!"
  51. On Error Resume Next
  52. End Function
  53. ' 这个子程序遍历对象,调用解散物件和居中
  54. Public Sub start_Center()
  55. Dim s As Shape, ssr As ShapeRange
  56. Set ssr = Smart_Group
  57. For Each s In ssr
  58. Ungroup_Center s
  59. Next s
  60. End Sub
  61. ' 以下函数,解散物件,以面积排序居中
  62. Private Function Ungroup_Center(os As Shape)
  63. Set grp = os.UngroupEx
  64. grp.Sort "@shape1.Width * @shape1.Height> @shape2.Width * @shape2.Height"
  65. cx = grp(1).CenterX
  66. cy = grp(1).CenterY
  67. For Each s In grp
  68. s.CenterX = cx
  69. s.CenterY = cy
  70. Next s
  71. End Function