[原创]不规则多边形区域填充的代码

hg999

在论坛学到了不少知识，也应该做点回报。

填充不是很快，别人画的偶然会出现程序无影响的现象，几百个填了近一个小时。发出来大家看看。但我自己用多条多段线画的不规则多边形可以很快填充。其中有几个窗口界面上的就不发了，只发了关键代码。

其中，Listbox1是从Excel取过来的数据。

程序可以利用查找图中的文字内容与EXcel取的数据对比，如相符，则填充文字所在区域周围的不规则的多边形。多边形里面的孤岛不填充。

代码如下：

Dim layerName As String
Dim entry As AcadLayer
Dim ghtc As Boolean
Dim colo As Integer

layerName = ""

For Each entry In ThisDrawing.Layers
layerName = entry.Name
If layerName = "填充" Then
ghtc = True
ThisDrawing.ActiveLayer = entry
Exit For
End If
Next

If ghtc <> True Then

Set entry = ThisDrawing.Layers.Add("填充")
ThisDrawing.ActiveLayer = entry

End If
entry.color = acGreen ' 指定"填充"图层的颜色为绿色
colo = 3
ThisDrawing.SendCommand "_-color" & vbCr & colo & vbCr
                Do
                If COMMANDNAME = "" Then
                Sleep 50
                Exit Do
                End If
                Loop

On Error GoTo errHandle

Dim Found
'Dim pt As Variant
Dim MyObject As AcadObject
Dim MyCollection As AcadModelSpace

UserForm1.TextBox1.text = ""
UserForm1.Hide
UserForm3.Show
  
Found = False    ' 设置变量初始值。

ZoomExtents

Set MyCollection = ThisDrawing.ModelSpace

For i = 0 To ListBox1.ListCount - 1

    DoEvents
   
    For Each MyObject In MyCollection    ' 对每个成员作一次迭代。
    'MsgBox MyObject.ObjectName
   
        If MyObject.ObjectName = "AcDbText" Then
            DoEvents
            Found = False
   
            If Left(MyObject.textString, 13) = ListBox1.List(i, 0) Then
     ' 如果 Text 属性值等于设定值则。
                Found = True    ' 将变量 Found 的值设成 True。
                MyObject.GetBoundingBox , MinPoint
                magnification = 2500

                ThisDrawing.Application.ZoomCenter pt, magnification

                ThisDrawing.SendCommand "_-bhatch" & vbCr & "p" & vbCr & "solid" & vbCr & MinPoint(0) & "," & MinPoint(1)&   vbCr & vbCr               
               
                Do
                If COMMANDNAME = "" Then
                Sleep 50
                'MsgBox "正在填充" & ListBox1.List(i, 0) & "！"
                Exit Do
                End If
                Loop

                ZoomExtents

                Exit For
       
            Else
                Found = False
            End If
        End If
    UserForm3.Label1.Caption = ListBox1.List(i, 0) & vbCrLf & "完成" & Round((i + 1) / ListBox1.ListCount, 2) * 100 & "%"
    Next
   
                colo = 70 + (i Mod 4) * 10
                ThisDrawing.SendCommand "_-color" & vbCr & colo & vbCr
                Do
                    If COMMANDNAME = "" Then
                        Sleep 50
                        Exit Do
                    End If
                Loop
   
  If Found = False Then
    Dim xbtext As String
    xbtext = TextBox1.text
    TextBox1.text = xbtext & ListBox1.List(i, 0) & vbCrLf
  End If

DoEvents
Next

errHandle:
    If Err.Number = -2145386493 Then
        MsgBox "填充定义边界未闭合！", vbCritical
    End If
    Err.Clear
   
  UserForm3.Hide
  UserForm1.Show