版主们,救命啊!

丹雪

有如下代码用来删除指定区域内的块参照(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

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

丹雪

我现在新建了一个过滤器也还是没有用啊! 我把以下这写代码 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,块也并没有清除!

丹雪

我已经按照楼上的说的,另外建了过滤器,代码如下: 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

在前面加上


Application.ZoomExtents

丹雪

lzh741206,我加了啊，还是不行!可不可以直接帮我调试一下看看啊!我现在再复制一份代码进来! 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

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

丹雪

lzh741206发表于2005-6-2 20:54:00在前面加上 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

丹雪

lzh741206发表于2005-6-3 9:51:00和获得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

今晚打老虎

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