求助高手帮忙修改下程序
<p>我想遍历图层"ab1"中的图块及图层"abcd"的闭合多段线,如果图块的坐标在闭合多段线的区域外,则把区域外的图块删除,如在闭合的区域内,则保留。</p><p>我想把图块的坐标点画圆，面域，把闭合多段线也进行面域，并求交，如有相交，则保留，没相交则删除，</p><p>可是我这个程序有问题，下面也不知道怎么编了，请高手帮帮忙，帮我修改一下。</p><p>Sub Example_Select() '选择某图层的图块与多段线区域比较<br/>Dim ssetObj As AcadSelectionSet<br/>On Error Resume Next<br/>Set ssetObj = ThisDrawing.SelectionSets.Add("SSET")<br/>If Err <> 0 Then<br/>Set ssetObj = ThisDrawing.SelectionSets.Item("SSET")<br/>ssetObj.Clear<br/>End If<br/> <br/>Dim mode As Integer<br/>Dim object As AcadEntity<br/> <br/>mode = acSelectionSetAll</p><p>Dim gpCode(1) As Integer<br/>Dim dataValue(1) As Variant<br/>gpCode(0) = 0<br/>dataValue(0) = "insert"<br/>gpCode(1) = 8<br/>dataValue(1) = "ab1"</p><p>Dim groupCode As Variant, dataCode As Variant<br/>groupCode = gpCode<br/>dataCode = dataValue<br/> <br/>ssetObj.Select mode, , , groupCode, dataCode</p><p>'提示有几个对象加入选择集<br/>MsgBox "图中有" & ssetObj.Count & "个图元已加入到选择集SSET中。"</p><p>'遍历程序<br/>For i = 0 To ssetObj.Count - 1<br/>Set object = ssetObj.Item(i)<br/>Next i</p><p>'定义变量为变体型<br/>Dim xy As Variant</p><p>'遍历选择集的对象<br/>For Each ent In ssetObj</p><p>'求出块对象的坐标<br/>xy = ent.InsertionPoint</p><p>'以下为绘制圆程序<br/>Dim cobj(0 To 0) As AcadCircle<br/>Set cobj(0) = ThisDrawing.ModelSpace.AddCircle(xy, 50)<br/>cobj(0).Layer = "ab1"</p><p>'对圆进行面域<br/>Dim regionobj As Variant<br/>regionobj = ThisDrawing.ModelSpace.AddRegion(cobj)<br/>cobj(0).Erase<br/>Next</p><p>'MsgBox "坐标是：" & xy(0)</p><p>'''''''''''''<br/>'以上部分为图块坐标提取程序</p><p>'''''''''''''''''''''''<br/>'以下部分为多段线提取并面域<br/>Dim ssetObj1 As AcadSelectionSet<br/>Set ssetObj1 = ThisDrawing.SelectionSets.Add("SSET1")<br/>If Err <> 0 Then<br/>Set ssetObj1 = ThisDrawing.SelectionSets.Item("SSET1")<br/>ssetObj1.Clear<br/>End If<br/> <br/>Dim mode1 As Integer<br/>Dim object1(0 To 0) As AcadEntity<br/> <br/>mode1 = acSelectionSetAll</p><p>Dim gpCode1(1) As Integer<br/>Dim dataValue1(1) As Variant<br/>gpCode1(0) = 0<br/>dataValue1(0) = "LWPOLYLINE"<br/>gpCode1(1) = 8<br/>dataValue1(1) = "abcd"<br/> <br/>Dim groupCode1 As Variant, dataCode1 As Variant<br/>groupCode1 = gpCode1<br/>dataCode1 = dataValue1<br/> <br/>ssetObj1.Select mode1, , , groupCode1, dataCode1</p><p>'显示有几个图元加入选择集内<br/>MsgBox "图中有" & ssetObj1.Count & "个图元已加入到选择集SSET中。"</p><p>For i1 = 0 To ssetObj1.Count - 1<br/>Set object1(0) = ssetObj1.Item(i1)</p><p>If Not Err Then</p><p>Dim regionobj1 As Variant<br/>regionobj1 = ThisDrawing.ModelSpace.AddRegion(object1)</p><p>End If<br/>Next i1</p><p><br/>Dim roundroomobj As AcadRegion<br/>Dim pillarobj As AcadRegion<br/>'If regionobj(0).Area > regionobj1(0).Area Then</p><p>Set roundroomobj = regionobj1(0)<br/>Set pillarobj = regionobj(0)</p><p>'Else<br/>'Set pillarobj = regionobj1(0)<br/>'Set roundroomobj = regionobj(0)<br/>'End If</p><p>roundroomobj.Color = acRed<br/>pillarobj.Color = acCyan</p><p>roundroomobj.Boolean acIntersection, pillarobj</p><p>End Sub</p><p><br/></p> <p>我的想法，通过过滤，选出abcd图层的多段线，然后创建新选集，通过选集SelectByPolygon，把选到的块添加到选集。删出选集中没有的块</p> 还是搞不来,请高手帮帮忙吧 <p>提供图纸测试</p> <p>改变下方法吧!判断块的插入点是否在多段线内(搜搜,有代码的),否就删了,</p> 本帖最后由 作者 于 2008-8-12 19:04:06 编辑这个是图纸，请高手们帮忙 <p>高手们,帮帮们吧,帮我编一下吧,我实在是编不出来了</p> Sub test()
On Error Resume Next
'多段线选集
Dim plsltset As AcadSelectionSet
ThisDrawing.SelectionSets.Add "plsltset"
Set plsltset = ThisDrawing.SelectionSets.Item("plsltset")
'初始化
plsltset.Clear
'过滤出abcd图层的多段线
Dim ft(0 To 1) As Integer
Dim fd(0 To 1) As Variant
ft(0) = 0
fd(0) = "LWPOLYLINE"
ft(1) = 8
fd(1) = "abcd"
plsltset.Select acSelectionSetAll, , , ft, fd
'块选集
Dim blksltset As AcadSelectionSet
ThisDrawing.SelectionSets.Add "blksltset"
Set blksltset = ThisDrawing.SelectionSets.Item("blksltset")
'初始化
blksltset.Clear
'多段线
Dim plobj As AcadLWPolyline
'块过滤
ft(0) = 0
fd(0) = "INSERT"
ft(1) = 8
fd(1) = "AB1"
'遍历多段线选集选择块
For Each plobj In plsltset
'多段线顶点
Dim plpts As Variant
plpts = plobj.Coordinates
'二维点转换为三维点
ReDim sspts(0 To ((UBound(plpts) + 1) * 3 / 2 - 1)) As Double
Dim j As Integer
j = 0
For i = 0 To UBound(plpts) - 1 Step 2
sspts(j) = plpts(i)
sspts(j + 1) = plpts(i + 1)
sspts(j + 2) = 0
j = j + 3
Next
'选择块
blksltset.SelectByPolygon acSelectionSetCrossingPolygon, sspts, ft, fd
Next
'选择所有AB1图层上的块
Dim allblksltset As AcadSelectionSet
ThisDrawing.SelectionSets.Add "allblksltset"
Set allblksltset = ThisDrawing.SelectionSets.Item("allblksltset")
allblksltset.Select acSelectionSetAll, , , ft, fd
ReDim objs(0 To blksltset.Count - 1) As Object
'多边形内的所有对象
For i = 0 To blksltset.Count - 1
Set objs(i) = blksltset(i)
Next
'剔除多边形内的对象
allblksltset.RemoveItems (objs)
'删除其余对象
allblksltset.Erase
'收工
End Sub
<p>楼上的写的非常不错</p> 谢谢楼上的兄弟了,我试用下
页:
[1]