jialan75 发表于 2017-8-9 11:06:45

智能群组源码


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


jialan75 发表于 2017-8-9 13:11:16


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

229914355 发表于 2017-8-9 11:59:10

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

TBH520 发表于 2017-8-9 13:34:56

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

timilpz 发表于 2017-8-9 14:19:47

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

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

asong 发表于 2017-8-10 01:39:32

szqinyi 发表于 2017-8-18 09:10:48

价格很贵,功能很单一。

00789 发表于 2017-8-22 13:10:26

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

00789 发表于 2017-8-22 15:15:20

很好,已经下载下来,正在探索中:D

繁星6666 发表于 2018-8-28 17:25:46

这个格式的不会用,白下了,太高深了
页: [1] 2 3
查看完整版本: 智能群组源码