028集—CAD中多边形从上到下、从左到右图形自动排序——vba代码实现

 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