智能群组源码

jialan75

[sell]
Public Type matrix
a1 As Double '矩形的四个点的坐标_左上
a2 As Double '矩形的四个点的坐标_右上
a3 As Double '矩形的四个点的坐标_左下
a4 As Double '矩形的四个点的坐标_右下
End Type
Dim t() As matrix, 容差 As Double
Sub 选中群组()
If ActiveSelection.Shapes.Count = 0 Then
MsgBox "选中2个以上的内容先。"
Else
加速_开启1
Dim sh As Shape, sq As Shape, s As Shape, news As New ShapeRange, 总数 As Double, 计数 As Double
容差 = 0
容差 = 容差 + 0.05
总数 = ActiveSelection.Shapes.Count
ReDim t(0 To 总数)
i = -1
For Each s In ActiveSelection.Shapes.All
i = i + 1
t(i).a1 = ActiveSelection.Shapes(i + 1).PositionX
t(i).a2 = ActiveSelection.Shapes(i + 1).PositionY
t(i).a3 = ActiveSelection.Shapes(i + 1).PositionX + ActiveSelection.Shapes(i + 1).SizeWidth
t(i).a4 = ActiveSelection.Shapes(i + 1).PositionY - ActiveSelection.Shapes(i + 1).SizeHeight
Next
一个很漫长的循环体 t
For i = 0 To UBound(t)
If t(i).a1 <> 0 Or t(i).a2 <> 0 Or t(i).a3 <> 0 Or t(i).a3 <> 0 Then
ActivePage.SelectShapesFromRectangle(t(i).a1 - rc, t(i).a2 + rc, t(i).a3 + rc, t(i).a4 - rc, True).Group '根据坐标群组对象
计数 = 计数 + 1
End If
Next
加速_关闭1
MsgBox "一共有：" + CStr(总数) + "个。" + Chr(10) + "群组后变成：" + CStr(计数) + "个。" '这行可以删除，不删除的话每次运行都弹出一个框
End If
End Sub

Private Function 一个很漫长的循环体(t() As matrix)
Dim 中间数据 As Integer
中间数据 = 0
    For i = 0 To UBound(t) - 1
       For k = i + 1 To UBound(t)
        If t(i).a1 <> 0 Or t(k).a1 <> 0 Then
            If AnB(t(i), t(k)) = True Then
            t(i) = AuB(t(i), t(k))
            t(k) = 数组变成零(t(k))
            中间数据 = 1
            End If
        End If
       Next
    Next
If 中间数据 = 1 Then 一个很漫长的循环体 t
End Function
Private Function 数组变成零(t1 As matrix) As matrix
t1.a1 = 0: t1.a2 = 0: t1.a3 = 0: t1.a4 = 0
数组变成零 = t1
End Function

Private Function AnB(t1 As matrix, t2 As matrix) As Boolean '刚刚学了高中数学的交集就用上了
a1 = t1.a1 - 容差: a2 = t1.a2 + 容差: a3 = t1.a3 + 容差: a4 = t1.a4 - 容差
b1 = t2.a1: b2 = t2.a2: b3 = t2.a3: b4 = t2.a4
If a1 <> b1 Or a2 <> b2 Or a3 <> b3 Or a4 <> b4 Then
AnB = Not (a1 > b3 Or a3 < b1 Or a2 < b4 Or a4 > b2)
End If
End Function
Private Function AuB(t1 As matrix, t2 As matrix) As matrix '刚刚学了高中数学的并集就用上了
a1 = t1.a1: a2 = t1.a2: a3 = t1.a3: a4 = t1.a4
b1 = t2.a1: b2 = t2.a2: b3 = t2.a3: b4 = t2.a4
If a1 > b1 Then a1 = b1
If a2 < b2 Then a2 = b2
If a3 < b3 Then a3 = b3
If a4 > b4 Then a4 = b4
AuB.a1 = a1: AuB.a2 = a2: AuB.a3 = a3: AuB.a4 = a4
End Function
Private Function 加速_开启1()
    ActiveDocument.BeginCommandGroup
    ActiveDocument.Unit = CDRMillimeter
    Optimization = True
    End Function

Private Function 加速_关闭1()
    Optimization = False
    Application.Refresh
    ActiveDocument.EndCommandGroup
End Function
[/sell]

jialan75

演示

不好意思不知道规则，现在附上图片。

229914355

1.首先，我不明白为什么管理员。给你的贴子加分，因为按论坛和管理规定，发贴出售一定要有图片加以注明！
2.这论坛管理员肯定要出来解释一下为什么给加分啊！这没道理啊，明明和规定相冲突.

TBH520

这个在实际应用中有什么作用呢？

timilpz

哇塞，楼主，你这纯代码分享，原生代码啊。

刚刚学了高中数学的并集就用上了 ，这句用途是？

szqinyi

价格很贵，功能很单一。

00789

找了好久但是印币不足怎么办

00789

很好，已经下载下来，正在探索中

繁星6666

这个格式的不会用，白下了，太高深了