cad图中多边形排序问题(从上到下、从左到右),加载此vba插件一键排序:
(使用方法:vbaman加载此插件,vbarun运行即可)
见下图:
排序前图片:
排序后:
另附部分代码:
Sub NumberPolygons()
'yngqq@2024年8月25日22:21:01
Dim doc As AcadDocument
Dim selSet As AcadSelectionSet
Dim poly As AcadLWPolyline
Dim centroid(2) As Double: Dim tempcentroid(2) As Double
Dim polyData() As Variant, centerx() As Double, centery() As Double
Dim i As Integer, j As Integer
Dim temp As Variant, tempv As Variant
Dim text As AcadText
Dim decim As Integer
' 获取当前文档
Set doc = ThisDrawing
' 创建或清除选择集
On Error Resume Next
Set selSet = doc.SelectionSets.Item("Polygons")
If Not selSet Is Nothing Then selSet.Delete
Set selSet = doc.SelectionSets.Add("Polygons")
On Error GoTo 0
' 选择所有四边形(LWPolylines)
selSet.SelectOnScreen
' 初始化数组来存储多边形和它们的质心
Dim mycca As Variant
' 获取每个多边形的质心
For i = 0 To selSet.Count - 1
If InStr(1, selSet.Item(i).ObjectName, "polyline", vbTextCompare) > 0 Then
'Set poly = selSet.Item(i)
mycca = CalculateCentroidAndArea(selSet.Item(i))
'centroid(0) = mycca(0): centroid(1) = mycca(1): centroid(2) = 0
ReDim Preserve polyData(j): ReDim Preserve centerx(j): ReDim Preserve centery(j)
Set polyData(j) = selSet.Item(i)
centerx(j) = mycca(0)
centery(j) = mycca(1)
j = j + 1
End If
Next i
' 按照从左到右,从上到下的顺序排列
For i = LBound(polyData) To UBound(polyData) - 1
For j = i + 1 To UBound(polyData)
''省略部分代码,完整qq443440204
Next j
Next i
' 在多边形的质心位置标注编号
For i = 0 To UBound(polyData)
' Set poly = polyData(i)
centroid(0) = centerx(i): centroid(1) = centery(i)
Set text = ThisDrawing.ModelSpace.AddText(CStr(i + 1), centroid, 100) ' 文本高度设置为1,可以根据需要调整
Next i
MsgBox "已完成!" & Space(20) & vbCr & "qq业务合作443440204", , "版权所有qq"
End Sub