- 积分
- 652
- 明经币
- 个
- 注册时间
- 2005-4-28
- 在线时间
- 小时
- 威望
-
- 金钱
- 个
- 贡献
-
- 激情
-
|
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 |
|