1
1

SmartGroup.bas 2.6 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980
  1. Attribute VB_Name = "SmartGroup"
  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 = "智能群组" SmartGroup 2023.6.30
  5. Public Function Smart_Group(Optional ByVal tr As Double = 0) As ShapeRange
  6. If 0 = ActiveSelectionRange.Count Then Exit Function
  7. On Error GoTo ErrorHandler
  8. API.BeginOpt
  9. Dim OrigSelection As ShapeRange, sr As New ShapeRange
  10. Dim s1 As Shape, sh As Shape, s As Shape
  11. Dim X As Double, Y As Double, w As Double, h As Double
  12. Dim eff1 As Effect
  13. Set OrigSelection = ActiveSelectionRange
  14. '// 遍历物件画矩形
  15. For Each sh In OrigSelection
  16. sh.GetBoundingBox X, Y, w, h
  17. If w * h > 4 Then
  18. Set s = ActiveLayer.CreateRectangle2(X - tr, Y - tr, w + 2 * tr, h + 2 * tr)
  19. sr.Add s
  20. '// 轴线 创建轮廓处理
  21. ElseIf w * h < 0.3 Then
  22. ' Debug.Print w * h
  23. Set eff1 = sh.CreateContour(cdrContourOutside, 0.5, 1, cdrDirectFountainFillBlend, CreateRGBColor(26, 22, 35), _
  24. CreateRGBColor(26, 22, 35), CreateRGBColor(26, 22, 35), 0, 0, cdrContourSquareCap, cdrContourCornerMiteredOffsetBevel, 15#)
  25. eff1.Separate
  26. End If
  27. Next sh
  28. '// 查找轴线轮廓
  29. sr.AddRange ActivePage.Shapes.FindShapes(Query:="@Outline.Color=RGB(26, 22, 35)")
  30. sr.AddRange ActivePage.Shapes.FindShapes(Query:="@fill.Color=RGB(26, 22, 35)")
  31. '// 新矩形寻找边界,散开,删除刚才画的新矩形
  32. Dim brk1 As ShapeRange
  33. Set s1 = sr.CustomCommand("Boundary", "CreateBoundary")
  34. Set brk1 = s1.BreakApartEx
  35. sr.Delete
  36. '// 矩形边界智能群组, RetSR 返回群组 和 删除矩形s
  37. Dim RetSR As New ShapeRange
  38. For Each s In brk1
  39. Set sr = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False).Shapes.all
  40. sr.DeleteItem sr.IndexOf(s)
  41. If sr.Count > 0 Then RetSR.Add sr.Group
  42. Next s
  43. '// 智能群组返回和选择
  44. Set Smart_Group = RetSR
  45. RetSR.CreateSelection
  46. ErrorHandler:
  47. API.EndOpt
  48. End Function
  49. '// 智能群组 原理版
  50. Private Function Smart_Group_ABC()
  51. ActiveDocument.Unit = cdrMillimeter
  52. Dim OrigSelection As ShapeRange, brk1 As ShapeRange
  53. Set OrigSelection = ActiveSelectionRange
  54. Dim s1 As Shape, sh As Shape, s As Shape
  55. Set s1 = OrigSelection.CustomCommand("Boundary", "CreateBoundary")
  56. Set brk1 = s1.BreakApartEx
  57. For Each s In brk1
  58. If s.SizeHeight > 10 Then
  59. Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
  60. sh.Shapes.all.Group
  61. End If
  62. s.Delete
  63. Next
  64. End Function