蘭雅 VBA 智能群组 SmartGroup.bas 代码详解

蘭雅

'// 这是免费且无附带条件的软件，发布到公共领域。
'// 更多信息请参考 https://github.com/hongwenjun

'// 属性 VB_Name = "智能群组" SmartGroup 2023.6.30

Public Function Smart_Group(Optional ByVal tr As Double = 0) As ShapeRange
  ' 如果没有选中的对象，则退出函数
  If 0 = ActiveSelectionRange.Count Then Exit Function
  On Error GoTo ErrorHandler
  API.BeginOpt

  ' 定义变量
  Dim OrigSelection As ShapeRange, sr As New ShapeRange
  Dim s1 As Shape, sh As Shape, s As Shape
  Dim X As Double, Y As Double, w As Double, h As Double
  Dim eff1 As Effect
  
  ' 获取当前选中的对象
  Set OrigSelection = ActiveSelectionRange

  ' 遍历选中的对象并画矩形
  For Each sh In OrigSelection
    sh.GetBoundingBox X, Y, w, h
    ' 如果宽度和高度的乘积大于4，则创建一个矩形
    If w * h > 4 Then
      Set s = ActiveLayer.CreateRectangle2(X - tr, Y - tr, w + 2 * tr, h + 2 * tr)
      sr.Add s

    ' 如果宽度和高度的乘积小于0.3，则创建轮廓处理
    ElseIf w * h < 0.3 Then
      ' Debug.Print w * h
      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#)
      eff1.Separate
    End If
  Next sh

  ' 查找轴线轮廓
  sr.AddRange ActivePage.Shapes.FindShapes(Query:="@Outline.Color=RGB(26, 22, 35)")
  sr.AddRange ActivePage.Shapes.FindShapes(Query:="@fill.Color=RGB(26, 22, 35)")

  ' 新矩形寻找边界，散开，删除刚才画的新矩形
  Dim brk1 As ShapeRange
  Set s1 = sr.CustomCommand("Boundary", "CreateBoundary")
  Set brk1 = s1.BreakApartEx
  sr.Delete

  ' 矩形边界智能群组, RetSR 返回群组和删除矩形s
  Dim RetSR As New ShapeRange
  For Each s In brk1
    Set sr = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False).Shapes.all
    sr.DeleteItem sr.IndexOf(s)
    If sr.Count > 0 Then RetSR.Add sr.Group
  Next s
  
  ' 智能群组返回和选择
  Set Smart_Group = RetSR
  RetSR.CreateSelection
  
ErrorHandler:
  API.EndOpt
End Function

' 智能群组 原理版
Private Function Smart_Group_ABC()
  ActiveDocument.Unit = cdrMillimeter
  
  ' 定义变量
  Dim OrigSelection As ShapeRange, brk1 As ShapeRange
  Set OrigSelection = ActiveSelectionRange
  Dim s1 As Shape, sh As Shape, s As Shape
  
  ' 创建边界并打散
  Set s1 = OrigSelection.CustomCommand("Boundary", "CreateBoundary")
  Set brk1 = s1.BreakApartEx

  ' 遍历打散的形状，选择并群组
  For Each s In brk1
    If s.SizeHeight > 10 Then
      Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
      sh.Shapes.all.Group
    End If
    s.Delete
  Next
End Function

CorelDRAW VBA 代码详细解释

代码结构

该代码包含两个函数：

Smart_Group(Optional ByVal tr As Double = 0) As ShapeRange：公共函数，执行智能群组操作，并返回群组后的形状范围。
Smart_Group_ABC()：私有函数，展示智能群组的原理。

`Smart_Group` 函数

参数

tr：可选参数，表示矩形扩大的距离，默认值为0。

变量定义

OrigSelection：保存原始选择的形状范围。
sr：保存新创建的矩形和轮廓形状。
s1、sh、s：循环和临时形状变量。
X、Y、w、h：形状的边界框参数。
eff1：轮廓效果对象。

代码逻辑

检查选择的形状
```
   If 0 = ActiveSelectionRange.Count Then Exit Function
```
如果没有选择任何形状，则退出函数。
开始错误处理和优化
```
   On Error GoTo ErrorHandler
   API.BeginOpt
```
启动错误处理，并开始优化性能。
遍历选择的形状
```
   For Each sh In OrigSelection
```
遍历原始选择的每个形状。
根据形状面积创建矩形或轮廓
- 如果形状面积大于4，则创建一个扩大tr距离的矩形，并添加到sr中。
- 如果形状面积小于0.3，则为该形状创建一个轮廓效果，并分离该效果。

查找特定颜色的形状

   sr.AddRange ActivePage.Shapes.FindShapes(Query:="@Outline.Color=RGB(26, 22, 35)")
   sr.AddRange ActivePage.Shapes.FindShapes(Query:="@fill.Color=RGB(26, 22, 35)")

查找页面上轮廓颜色或填充颜色为RGB(26, 22, 35)的形状，并添加到sr中。

创建边界并打散
```
   Set s1 = sr.CustomCommand("Boundary", "CreateBoundary")
   Set brk1 = s1.BreakApartEx
   sr.Delete
```
对sr中的形状创建边界，并打散成单独的形状，存储在brk1中，并删除原始形状。

遍历打散的形状并群组

   For Each s In brk1
       Set sr = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False).Shapes.all
       sr.DeleteItem sr.IndexOf(s)
       If sr.Count > 0 Then RetSR.Add sr.Group
   Next s

遍历打散的每个形状s，在s的边界内选择所有形状，并删除s自己。如果剩余形状数量大于0，则群组这些形状，并添加到RetSR中。

返回结果并选择
```
   Set Smart_Group = RetSR
   RetSR.CreateSelection
```
将RetSR赋值给函数返回值，并选择这些形状。
错误处理
```
   ErrorHandler:
       API.EndOpt
```
结束优化，并处理错误。

`Smart_Group_ABC` 函数

代码逻辑

设置文档单位
```
   ActiveDocument.Unit = cdrMillimeter
```
将文档单位设置为毫米。
定义变量
- OrigSelection：保存原始选择的形状范围。
- brk1：打散后的形状范围。
创建边界并打散
```
   Set s1 = OrigSelection.CustomCommand("Boundary", "CreateBoundary")
   Set brk1 = s1.BreakApartEx
```
对原始选择的形状创建边界，并打散成单独的形状，存储在brk1中。

遍历打散的形状并群组

   For Each s In brk1
       If s.SizeHeight > 10 Then
           Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, False)
           sh.Shapes.all.Group
       End If
       s.Delete
   Next

遍历打散的每个形状s，如果形状高度大于10，则在s的边界内选择所有形状，并群组这些形状，然后删除s。

代码总结

该代码通过创建边界、打散形状、选择和群组形状，实现了对复杂图形的智能群组操作。Smart_Group 函数是主要的执行函数，Smart_Group_ABC 函数展示了智能群组的原理。

zry2

谢谢分享

xinhairen

学习了，感谢兰总