hg999 发表于 2008-1-18 22:19:00

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

<p>在论坛学到了不少知识，也应该做点回报。</p><p>填充不是很快，别人画的偶然会出现程序无影响的现象，几百个填了近一个小时。发出来大家看看。但我自己用多条多段线画的不规则多边形可以很快填充。其中有几个窗口界面上的就不发了，只发了关键代码。</p><p>其中，Listbox1是从Excel取过来的数据。</p><p>程序可以利用查找图中的文字内容与EXcel取的数据对比，如相符，则填充文字所在区域周围的不规则的多边形。多边形里面的孤岛不填充。</p><p>代码如下：</p><p>Dim layerName As String<br/>Dim entry As AcadLayer<br/>Dim ghtc As Boolean<br/>Dim colo As Integer</p><p>layerName = ""</p><p>For Each entry In ThisDrawing.Layers<br/>layerName = entry.Name<br/>If layerName = "填充" Then<br/>ghtc = True<br/>ThisDrawing.ActiveLayer = entry<br/>Exit For<br/>End If<br/>Next</p><p>If ghtc &lt;&gt; True Then</p><p>Set entry = ThisDrawing.Layers.Add("填充")<br/>ThisDrawing.ActiveLayer = entry</p><p>End If<br/>entry.color = acGreen ' 指定"填充"图层的颜色为绿色<br/>colo = 3<br/>ThisDrawing.SendCommand "_-color" &amp; vbCr &amp; colo &amp; vbCr<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Do<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If COMMANDNAME = "" Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Sleep 50<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit Do<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Loop</p><p>On Error GoTo errHandle</p><p>Dim Found<br/>'Dim pt As Variant<br/>Dim MyObject As AcadObject<br/>Dim MyCollection As AcadModelSpace</p><p>UserForm1.TextBox1.text = ""<br/>UserForm1.Hide<br/>UserForm3.Show<br/>&nbsp;&nbsp; <br/>Found = False&nbsp;&nbsp;&nbsp; ' 设置变量初始值。</p><p>ZoomExtents</p><p>Set MyCollection = ThisDrawing.ModelSpace</p><p>For i = 0 To ListBox1.ListCount - 1</p><p>&nbsp;&nbsp;&nbsp; DoEvents<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp; For Each MyObject In MyCollection&nbsp;&nbsp;&nbsp; ' 对每个成员作一次迭代。<br/>&nbsp;&nbsp;&nbsp; 'MsgBox MyObject.ObjectName<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If MyObject.ObjectName = "AcDbText" Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; DoEvents<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Found = False<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If Left(MyObject.textString, 13) = ListBox1.List(i, 0) Then<br/>&nbsp;&nbsp;&nbsp;&nbsp; ' 如果 Text 属性值等于设定值则。<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Found = True&nbsp;&nbsp;&nbsp; ' 将变量 Found 的值设成 True。<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; MyObject.GetBoundingBox , MinPoint<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; magnification = 2500</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ThisDrawing.Application.ZoomCenter pt, magnification</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ThisDrawing.SendCommand "_-bhatch" &amp; vbCr &amp; "p" &amp; vbCr &amp; "solid" &amp; vbCr &amp; MinPoint(0) &amp; "," &amp; MinPoint(1)&amp;&nbsp;&nbsp; vbCr &amp; vbCr&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Do<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If COMMANDNAME = "" Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Sleep 50<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; 'MsgBox "正在填充" &amp; ListBox1.List(i, 0) &amp; "！"<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit Do<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Loop</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ZoomExtents</p><p>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit For<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Else<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Found = False<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; UserForm3.Label1.Caption = ListBox1.List(i, 0) &amp; vbCrLf &amp; "完成" &amp; Round((i + 1) / ListBox1.ListCount, 2) * 100 &amp; "%"<br/>&nbsp;&nbsp;&nbsp; Next<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; colo = 70 + (i Mod 4) * 10<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ThisDrawing.SendCommand "_-color" &amp; vbCr &amp; colo &amp; vbCr<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Do<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; If COMMANDNAME = "" Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Sleep 50<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Exit Do<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; Loop<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp; If Found = False Then<br/>&nbsp;&nbsp;&nbsp; Dim xbtext As String<br/>&nbsp;&nbsp;&nbsp; xbtext = TextBox1.text<br/>&nbsp;&nbsp;&nbsp; TextBox1.text = xbtext &amp; ListBox1.List(i, 0) &amp; vbCrLf<br/>&nbsp; End If</p><p>DoEvents<br/>Next</p><p>errHandle:<br/>&nbsp;&nbsp;&nbsp; If Err.Number = -2145386493 Then<br/>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; MsgBox "填充定义边界未闭合！", vbCritical<br/>&nbsp;&nbsp;&nbsp; End If<br/>&nbsp;&nbsp;&nbsp; Err.Clear<br/>&nbsp;&nbsp;&nbsp; <br/>&nbsp; UserForm3.Hide<br/>&nbsp; UserForm1.Show<br/>&nbsp; <br/></p>
页: [1]
查看完整版本: [原创]不规则多边形区域填充的代码