请大家指点指点啊！！急

丹雪发表于 2005-5-26 20:56:00

有以下代码，根据不同情况实行拉伸实体的操作，可为什么存在拉伸路径的时候，只能够拉伸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

页: [1]

明经CAD社区's Archiver

请大家指点指点啊！！急