请大家指点指点啊！！急

丹雪

有以下代码，根据不同情况实行拉伸实体的操作，可为什么存在拉伸路径的时候，只能够拉伸ExtrudeFace层中的面，而须绘制路径的时候则可以拉伸所有面！ Private Sub CInput_Click()

Form2.Hide
Dim objlayer As AcadLayer

Dim r As Integer
Dim t As Integer

r = Val(PHeight.Text)
t = Val(RThickness.Text)
如果层ExtrudePath不存在，就创建一个明为ExtrudePath的层，如果存在就置为当前层。
On Error Resume Next If IsNull(ThisDrawing.Layers.Item("ExtrudePath")) Then
Set objlayer = ThisDrawing.Layers.Add("ExtrudePath")
ThisDrawing.ActiveLayer = objlayer Else
For Each objlayer In ThisDrawing.Layers
If objlayer.Name = "ExtrudePath" Then
ThisDrawing.ActiveLayer = objlayer
Exit For
End If
Next
End If 判断ExtrudePath层中是否存在三维多段线，如果有两条以上，就要求用户选择其中一条做为拉伸路径objline，如果只有一条，就直接作为拉伸路径objline,如果没有的话，就绘制一条拉伸路径objline Dim objline As Acad3DPolyline
Dim tpoint As Variant
tpoint(0) = Val(Form2.XPoint.Text)
tpoint(1) = Val(Form2.YPoint.Text)
tpoint(2) = Val(Form2.ZPoint.Text)
Dim sset As AcadSelectionSet
Dim sset1 As AcadSelectionSet Dim y As Integer
y = ThisDrawing.SelectionSets.Count While (y > 0)
Set sset = ThisDrawing.SelectionSets.Item(y - 1)
If sset.Name = "3dPLine" Or "A3dPLine" Then
sset.Delete
End If
y = y - 1
Wend Set sset = ThisDrawing.SelectionSets.Add("3dPLine")
Set sset1 = ThisDrawing.SelectionSets.Add("A3dPLine") Dim gpcode(1) As Integer
Dim datavalue(1) As Variant gpcode(0) = 0
datavalue(0) = "PolyLine"
gpcode(1) = 8
datavalue(1) = "ExtrudePath"
sset.Select acSelectionSetAll, , , gpcode, datavalue
If sset.Count > 1 Then MsgBox "满足条件的拉伸路径存在多条，请选择一条！" sset1.SelectOnScreen gpcode, datavalue
Set objline = sset1.Item(0) objline.Move objline.Coordinate(0), tpoint For i = 0 To sset.Count - 1 If Not sset.Item(i).ObjectID = sset1.Item(0).ObjectID Then
sset.Item(i).Delete
End If Next i Else If sset.Count = 1 Then
Set objline = sset.Item(0)
objline.Move objline.Coordinate(0), tpoint Else
For Each objlayer In ThisDrawing.Layers
If objlayer.Name = "ExtrudePath" Then
ThisDrawing.ActiveLayer = objlayer
End If
Exit For
Next 绘制三维多段线，且其起始点已经确定 On Error GoTo errhandle
'Dim p1 As Variant
Dim p2 As Variant
'p1 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入第一点:")
p2 = ThisDrawing.Utility.GetPoint(, vbCr & "请输入下一点:")
Dim pnt(5) As Double
pnt(0) = Val(Form2.XPoint.Text): pnt(1) = Val(Form2.YPoint.Text): pnt(2) = Val(Form2.ZPoint.Text)
pnt(3) = p2(0): pnt(4) = p2(1): pnt(5) = p2(2) Set objline = ThisDrawing.ModelSpace.Add3DPoly(pnt)
Do While True
p2 = ThisDrawing.Utility.GetPoint(p2, vbCr & "请输入下一点:")
objline.AppendVertex p2
Loop
errhandle:
End If End If 把该三维多段线的起始点做为新建ucs的原点，第二点作为另外一个参数

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

Dim str1 As String
Dim str2 As String 'coord1 = objline.Coordinate(0) 'coord2 = objline.Coordinate(1)
coord1 = ThisDrawing.Utility.TranslateCoordinates(objline.Coordinate(0), acWorld, acUCS, False)
coord2 = ThisDrawing.Utility.TranslateCoordinates(objline.Coordinate(1), acWorld, acUCS, False)
endpoint1(0) = coord1(0): endpoint1(1) = coord1(1): endpoint1(2) = coord1(2)
endpoint2(0) = coord2(0): endpoint2(1) = coord2(1): endpoint2(2) = coord2(2)
str1 = endpoint1(0) & "," & endpoint1(1) & "," & endpoint1(2)
str2 = endpoint2(0) & "," & endpoint2(1) & "," & endpoint2(2) ThisDrawing.SendCommand "_ucs " & "N" & vbCr & "za" & vbCr & str1 & vbCr & str2 & vbCr 分别在层extrudeFacel和0层中绘制面 以下的创建面的函数存在于模块中
Call CreateRegion1(100 * Val(Form1.LPbox1.Text), 100 * Val(Form1.MCbox1.Text), 100 * Val(Form1.RPbox1.Text), 100 * Val(Form1.LTbox1.Text), 100 * ValForm1.RTbox1.Text)) 建立包含所有ExtrudeFace层中的面的选择集ssetF
Dim ssetF As AcadSelectionSet
Dim x As Integer
x = ThisDrawing.SelectionSets.Count
While (x > 0)
Set ssetF = ThisDrawing.SelectionSets.Item(x - 1)
If ssetF.Name = "ExtrudeFace" Then
ssetF.Delete
End If
x = x - 1
Wend
Set ssetF = ThisDrawing.SelectionSets.Add("ExtrudeFace")
gpcode(0) = 0
datavalue(0) = "Region"
gpcode(1) = 8
datavalue(1) = "ExtrudeFace"
ssetF.Select acSelectionSetAll, , , gpcode, datavalue 拉伸所有ExtrudeFace层中的面创建实体 Dim obj3dPath() As Acad3DSolid
For i = 0 To ssetF.Count - 1
ReDim obj3dPath(i)
Set obj3dPath(i) = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(ssetF(i), objline)
obj3dPath(i).TrueColor = ssetF(i).TrueColor
ssetF(i).Delete
obj3dPath(i).Layer = "Path"
Next i objline.Layer = "0" 建立包含所有0层中的面的选择集sseth Dim sseth As AcadSelectionSet
i = ThisDrawing.SelectionSets.Count While (i > 0)
Set sseth = ThisDrawing.SelectionSets.Item(i - 1)
If sseth.Name = "helpobj" Then
sseth.Delete
End If
i = i - 1
Wend gpcode(0) = 0
datavalue(0) = "Region"
gpcode(1) = 8
datavalue(1) = "0"
sseth.Select acSelectionSetAll, , , gpcode, datavalue 拉伸0层中的面
Dim hobj3dPath As Acad3DSolid Set hobj3dPath = ThisDrawing.ModelSpace.AddExtrudedSolidAlongPath(sseth.Item(0), objline)
objline.Delete
sseth.Item(0).Delete
hobj3dPath.Layer = "0"
End If end sub