版主们,救命啊!

丹雪发表于 2005-6-2 12:07:00

有如下代码用来删除指定区域内的块参照(Block Reference),可老是起不了作用啊!

怎么办?救救我啊

Public Sub DelBlock()

建立选择集setp和setb,分别用来选择围成区域的3维多段线,和块参照 Dim setb As AcadSelectionSet Dim setp As AcadSelectionSet Dim i As Integer Dim y As Integer Dim j As Integer Dim k As Integer

i = ThisDrawing.SelectionSets.Count

While (i) Set setb = ThisDrawing.SelectionSets.Item(i - 1) If setb.Name = "BlockR" Or setb.Name = "objlh" Then setb.Delete End If i = i - 1 Wend

Set setb = ThisDrawing.SelectionSets.Add("BlockR") Set setp = ThisDrawing.SelectionSets.Add("objlh")

Dim gpcode(1) As Integer Dim datavalue(1) As Variant

gpcode(0) = 0 datavalue(0) = "polyline" gpcode(1) = 8 datavalue(1) = "Pathh" setp.Select acSelectionSetAll, , , gpcode, datavalue

获得4条3维多段线的4个交点

Dim obj1 As Acad3DPolyline Dim obj2 As Acad3DPolyline Dim pnt As Variant Dim pt(0 To 4, 0 To 2) As Variant

For k = 0 To 4 For i = 0 To setp.Count - 1 Set obj1 = setp.Item(i) For j = i + 1 To setp.Count - 1 Set obj2 = setp.Item(j) pnt = obj1.IntersectWith(obj2, acExtendNone) If VarType(pnt) <> vbEmpty Then For y = LBound(pnt) To UBound(pnt) pt(k, y) = pnt(y) 'MsgBox "pt(" & k & "," & y & ")" & ":" & pt(k, y) Next y If k < 4 Then k = k + 1 End If End If Next j Next i Next k

setp.Erase

'把得到的点组成pointList

Dim pts(0 To 11) As Double For i = 0 To 11 For j = 1 To 4 For k = 0 To 2 pts(i) = pt(j, k) 'MsgBox pts(i) If i < 11 Then i = i + 1 End If Next k Next j Next i

用以上点绘制三维多段线

Dim objline As Acad3DPolyline Set objline = ThisDrawing.ModelSpace.Add3DPoly(pts)

选择3维多段线的角点中的两个点

Dim endpoint1(0 To 2) As Double Dim endpoint2(0 To 2) As Double Dim coord1 As Variant Dim coord2 As Variant

coord1 = objline.Coordinate(0) coord2 = objline.Coordinate(3)

endpoint1(0) = coord1(0): endpoint1(1) = coord1(1): endpoint1(2) = coord1(2) endpoint2(0) = coord2(0): endpoint2(1) = coord2(1): endpoint2(2) = coord2(2) objline.Delete

 gpcode(0) = 0

datavalue(0) = "insert" setb.Select acSelectionSetAll, endpoint1, endpoint2, gpcode, datavalue MsgBox setb.Count

setb.Erase End Sub

这里声明一下:一直到获得两个点的地方却正确,可就是不能够选择块参照

雪山飞狐_lzh 发表于 2005-6-2 16:24:00

选择块参照的时候要另外建一个过滤器，否则gpcode(1)和datavalue(1)依然有值，会只选择Pathh层的块参照

丹雪发表于 2005-6-2 18:56:00

我现在新建了一个过滤器也还是没有用啊!

我把以下这写代码

gpcode(0) = 0

datavalue(0) = "insert" setb.Select acSelectionSetAll, endpoint1, endpoint2, gpcode, datavalue MsgBox setb.Count

setb.Erase

改成 

Dim fType(0 To 1) As Integer Dim fData(0 To 1) As Variant fType(0) = 0: fData(0) = "insert" fType(1) = 8: fData(1) = "ExtrudeFace,zz-1" setb.SelectByPolygon acSelectionSetCrossingPolygon, pts, fType, fData

MsgBox setb.Count

setb.Erase 

可运行后还是提示setb的数量为0,块也并没有清除!

丹雪发表于 2005-6-2 18:58:00

我已经按照楼上的说的,另外建了过滤器,代码如下:

Dim fType(0 To 1) As Integer Dim fData(0 To 1) As Variant fType(0) = 0: fData(0) = "insert" fType(1) = 8: fData(1) = "ExtrudeFace,zz-1" setb.SelectByPolygon acSelectionSetCrossingPolygon, pts, fType, fData

Msgbox setb.Count

setb.Erase

还是显示数量为0,且并没有清除任何块啊!

雪山飞狐_lzh 发表于 2005-6-2 20:54:00

在前面加上

Application.ZoomExtents

丹雪发表于 2005-6-3 09:33:00

<A name=36608>lzh741206</A>,我加了啊，还是不行!可不可以直接帮我调试一下看看啊!我现在再复制一份代码进来!

Public Sub DelBlock() Dim setb As AcadSelectionSet Dim setp As AcadSelectionSet Dim i As Integer Dim y As Integer Dim j As Integer Dim k As Integer

i = ThisDrawing.SelectionSets.Count

While (i) Set setb = ThisDrawing.SelectionSets.Item(i - 1) If setb.Name = "BlockR" Or setb.Name = "objlh" Then setb.Delete End If i = i - 1 Wend

Set setb = ThisDrawing.SelectionSets.Add("BlockR") Set setp = ThisDrawing.SelectionSets.Add("objlh")

Dim gpcode(1) As Integer Dim datavalue(1) As Variant

gpcode(0) = 0 datavalue(0) = "polyline" gpcode(1) = 8 datavalue(1) = "Pathh" setp.Select acSelectionSetAll, , , gpcode, datavalue

Dim obj1 As Acad3DPolyline Dim obj2 As Acad3DPolyline Dim pnt As Variant Dim pt(0 To 4, 0 To 2) As Variant

For k = 0 To 4 For i = 0 To setp.Count - 1 Set obj1 = setp.Item(i) For j = i + 1 To setp.Count - 1 Set obj2 = setp.Item(j) pnt = obj1.IntersectWith(obj2, acExtendNone) If VarType(pnt) <> vbEmpty Then For y = LBound(pnt) To UBound(pnt) pt(k, y) = pnt(y) 'MsgBox "pt(" & k & "," & y & ")" & ":" & pt(k, y) Next y If k < 4 Then k = k + 1 End If End If Next j Next i Next k

setp.Erase

Dim pts(0 To 11) As Double For i = 0 To 11 For j = 1 To 4 For k = 0 To 2 pts(i) = pt(j, k) 'MsgBox pts(i) If i < 11 Then i = i + 1 End If Next k Next j Next i

Application.ZoomExtents

Dim fType(0 To 1) As Integer Dim fData(0 To 1) As Variant fType(0) = 0: fData(0) = "insert" fType(1) = 8: fData(1) = "ExtrudeFace,zz-1" setb.SelectByPolygon acSelectionSetCrossingPolygon, pts, fType, fData

MsgBox setb.Count

 setb.Erase End Sub

雪山飞狐_lzh 发表于 2005-6-3 09:51:00

和获得4条3维多段线的4个交点构成的顺序有关

丹雪发表于 2005-6-3 10:12:00

lzh741206发表于2005-6-2 20:54:00static/image/common/back.gif在前面加上

Application.ZoomExtents

 

我加了还是不行!

版主帮我看看啊?

Dim setb As AcadSelectionSet Dim setp As AcadSelectionSet Dim i As Integer Dim y As Integer Dim j As Integer Dim k As Integer

i = ThisDrawing.SelectionSets.Count

While (i) Set setb = ThisDrawing.SelectionSets.Item(i - 1) If setb.Name = "BlockR" Or setb.Name = "objlh" Then setb.Delete End If i = i - 1 Wend

Set setb = ThisDrawing.SelectionSets.Add("BlockR") Set setp = ThisDrawing.SelectionSets.Add("objlh")

Dim gpcode(1) As Integer Dim datavalue(1) As Variant

gpcode(0) = 0 datavalue(0) = "polyline" gpcode(1) = 8 datavalue(1) = "Pathh" setp.Select acSelectionSetAll, , , gpcode, datavalue

Dim obj1 As Acad3DPolyline Dim obj2 As Acad3DPolyline Dim pnt As Variant Dim pt(0 To 4, 0 To 2) As Variant

For k = 0 To 4 For i = 0 To setp.Count - 1 Set obj1 = setp.Item(i) For j = i + 1 To setp.Count - 1 Set obj2 = setp.Item(j) pnt = obj1.IntersectWith(obj2, acExtendNone) If VarType(pnt) <> vbEmpty Then For y = LBound(pnt) To UBound(pnt) pt(k, y) = pnt(y) 'MsgBox "pt(" & k & "," & y & ")" & ":" & pt(k, y) Next y If k < 4 Then k = k + 1 End If End If Next j Next i Next k

setp.Erase

Dim pts(0 To 11) As Double For i = 0 To 11 For j = 1 To 4 For k = 0 To 2 pts(i) = pt(j, k) 'MsgBox pts(i) If i < 11 Then i = i + 1 End If Next k Next j Next i

Application.ZoomExtents

Dim fType(0 To 1) As Integer Dim fData(0 To 1) As Variant fType(0) = 0: fData(0) = "insert" fType(1) = 8: fData(1) = "ExtrudeFace,zz-1" setb.SelectByPolygon acSelectionSetCrossingPolygon, pts, fType, fData

MsgBox setb.Count

 setb.Erase End Sub

丹雪发表于 2005-6-3 14:06:00

lzh741206发表于2005-6-3 9:51:00static/image/common/back.gif和获得4条3维多段线的4个交点构成的顺序有关

我把点的顺序也更改了,但还是不行!帮忙看看吧!

 Public Sub DelBlock() Dim setb As AcadSelectionSet Dim setp As AcadSelectionSet Dim i As Integer Dim y As Integer Dim j As Integer Dim k As Integer

i = ThisDrawing.SelectionSets.Count

While (i) Set setb = ThisDrawing.SelectionSets.Item(i - 1) If setb.Name = "BlockR" Or setb.Name = "objlh" Then setb.Delete End If i = i - 1 Wend

Set setb = ThisDrawing.SelectionSets.Add("BlockR") Set setp = ThisDrawing.SelectionSets.Add("objlh")

Dim gpcode(1) As Integer Dim datavalue(1) As Variant

gpcode(0) = 0 datavalue(0) = "polyline" gpcode(1) = 8 datavalue(1) = "Pathh" setp.Select acSelectionSetAll, , , gpcode, datavalue

Dim obj1 As Acad3DPolyline Dim obj2 As Acad3DPolyline Dim pnt As Variant Dim pt(0 To 4, 0 To 2) As Variant

For k = 0 To 4 For i = 0 To setp.Count - 1 Set obj1 = setp.Item(i) For j = i + 1 To setp.Count - 1 Set obj2 = setp.Item(j) pnt = obj1.IntersectWith(obj2, acExtendNone) If VarType(pnt) <> vbEmpty Then For y = LBound(pnt) To UBound(pnt) pt(k, y) = pnt(y) 'MsgBox "pt(" & k & "," & y & ")" & ":" & pt(k, y) Next y If k < 4 Then k = k + 1 End If End If Next j Next i Next k

setp.Erase

Dim pts(0 To 11) As Double For i = 0 To 11 For j = 1 To 4 For k = 0 To 2 pts(i) = pt(j, k) If i < 11 Then i = i + 1 End If Next k Next j Next i

Dim tp(0 To 3) As Double For i = 9 To 11 tp(i - 9) = pts(i) pts(i) = pts(i - 3) pts(i - 3) = tp(i - 9) Next i

 For i = 0 To 11 MsgBox pts(i) Next i

 Application.ZoomExtents

Dim fType(0 To 1) As Integer Dim fData(0 To 1) As Variant fType(0) = 0: fData(0) = "insert" fType(1) = 8: fData(1) = "ExtrudeFace,zz-1" setb.SelectByPolygon acSelectionSetCrossingPolygon, pts, fType, fData

MsgBox setb.Count

 setb.Erase End Sub

今晚打老虎 发表于 2005-6-3 17:57:00

你的树和路灯的z轴坐标最少为30,你用一根z轴坐标为0的多段线的intersectwith方法就根本得不到任何的交点。

页: [1] 2

明经CAD社区's Archiver

版主们,救命啊!