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