|
|
Private Sub ChOrDPath3_Click()
Form1.Hide
On Error Resume Next
Dim objlayer As AcadLayer
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
Dim sset As AcadSelectionSet
Dim i As Integer
i = ThisDrawing.SelectionSets.Count
While (i > 0)
Set sset = ThisDrawing.SelectionSets.Item(i - 1)
If sset.Name = "3dPLine" Then
sset.Delete
End If
i = i - 1
Wend
Set sset = ThisDrawing.SelectionSets.Add("3dPLine")
Dim gpcode(1) As Integer
Dim datavalue(1) As Variant
gpcode(0) = 0
datavalue(0) = "PolyLine"
gpcode(1) = 8
datavalue(1) = "ExtrudePath"
Dim objline As Acad3DPolyline
Dim topoint1(0 To 2) As Variant
topoint1(0) = Val(Form2.XPoint.Text)
topoint1(1) = Val(Form2.YPoint.Text)
topoint1(2) = Val(Form2.ZPoint.Text)
sset.Select acSelectionSetAll, , , gpcode, datavalue
If sset.Count > 1 Then
MsgBox "满足条件的拉伸路径存在多条，请选择一条！"
sset.Clear
sset.SelectOnScreen gpcode, datavalue
Set objline = sset.Item(0)
objline.Move objline.Coordinate(0), topoint1
Else
If sset.Count = 1 Then
Set objline = sset.Item(0)
objline.Move objline.Coordinate(0), topoint1
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 p2 As Variant
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
（以上代码实现了“如果层ExtrudePath里面有超过一条3维多段线时，要求用户确定其中一条作为拉伸路径；如果恰好有条的话就自动作为拉伸路径；如果没有的话，就要求用户绘制一条3维多段线作为拉伸路径“。接下来的代码是为了获得当前三维多段线的相关参数，另外画一条三维多段线。可为什么运行的时候总是说过程无效？line1为空值）
Dim endpoint1(0 To 5) As Variant
Dim coord1 As Variant
Dim coord2 As Variant
coord1 = objline.Coordinate(1)
coord2 = objline.Coordinate(0)
Dim line1 As Acad3DPolyline
endpoint1(0) = 0: endpoint1(1) = coord1(1): endpoint1(2) = coord2(2)
endpoint1(3) = coord1(0): endpoint1(4) = coord1(1): endpoint1(5) = coord1(2)
Set line1 = ThisDrawing.ModelSpace.Add3DPoly(endpoint1)
End Sub |
|
置顶卡
