[求助]关于如何交互绘制ployline的问题
请问各位，如何通过getpoint命令来绘制polyline，下面是我绘制line的程序，想同样实现绘制ployline，但无法实现，请高手指点。Sub sdl()
Dim entry As AcadLineType
Dim found As Boolean
found = False
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, "acad_iso05w100", 1) = 0 Then
found = True
Exit For
End If
Next
If Not (found) Then ThisDrawing.Linetypes.Load "acad_iso05w100", "acadiso.lin"
Dim pt1 As Variant
Dim pt2 As Variant
Dim line3 As AcadLine
pt1 = ThisDrawing.Utility.GetPoint(, "起点")
10:
On Error GoTo 20
pt2 = ThisDrawing.Utility.GetPoint(pt1, "下一点")
Set line3 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
Dim lcx As AcadLayer
Set lcx = ThisDrawing.Layers.add("虚线层")
lcx.Color = acCyan
lcx.linetype = "acad_iso05w100"
line3.Layer = "虚线层"
'line3.linetype = "acad_iso04w100"
pt1 = pt2
GoTo 10
20: Exit Sub
End Sub 看看行不行
Sub kkk()
Dim entry As AcadLineType
Dim found As Boolean
found = False
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, "acad_iso05w100", 1) = 0 Then
found = True
Exit For
End If
Next
If Not (found) Then ThisDrawing.Linetypes.Load "acad_iso05w100", "acadiso.lin"
Dim fzpl As AcadPolyline
Dim zbd As Variant
Dim zbd1 As Variant
Dim i As Integer
Dim blist() As Double
Dim lcx As AcadLayer
Set lcx = ThisDrawing.Layers.Add("虚线层")
lcx.Color = acCyan
On Error Resume Next
Do
If IsEmpty(zbd1) Then
zbd = ThisDrawing.Utility.GetPoint(, "第一点：")
Else
zbd = ThisDrawing.Utility.GetPoint(zbd1, "下一点：")
End If
If Err Then
Err.Clear
Exit Do
End If
ReDim Preserve blist(3 * i + 2)
blist(3 * i) = zbd(0): blist(3 * i + 1) = zbd(1): blist(3 * i + 2) = zbd(2)
i = i + 1
zbd1 = zbd
Loop
Set fzpl = ThisDrawing.ModelSpace.AddPolyline(blist)
fzpl.Linetype = "acad_iso05w100"
fzpl.Layer = "虚线层"
End Sub
知道了起点和第二点之后就可以八绘制一条多段线了，以后的点通过AddVertex来添加。
Sub Example_AddVertex()
' This example creates a light weight polyline in model space.
' It then adds a vertex to the polyline.
Dim plineObj As AcadLWPolyline
Dim points(0 To 9) As Double
' Define the 2D polyline points
points(0) = 1: points(1) = 1
points(2) = 1: points(3) = 2
points(4) = 2: points(5) = 2
points(6) = 3: points(7) = 2
points(8) = 4: points(9) = 4
' Create a light weight Polyline object in model space
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
ZoomAll
MsgBox "Add a vertex to the end of the polyline.", , "AddVertex Example"
' Define the new vertex
Dim newVertex(0 To 1) As Double
newVertex(0) = 4: newVertex(1) = 1
' Add the vertex to the polyline
plineObj.AddVertex 5, newVertex
plineObj.Update
MsgBox "Vertex added.", , "AddVertex Example"
End Sub
完善一下：
Sub kkk()
Dim entry As AcadLineType
Dim found As Boolean
found = False
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, "acad_iso05w100", 1) = 0 Then
found = True
Exit For
End If
Next
If Not (found) Then ThisDrawing.Linetypes.Load "acad_iso05w100", "acadiso.lin"
Dim fzpl As AcadPolyline
Dim zbd As Variant
Dim zbd1 As Variant
Dim i As Integer
Dim blist() As Double
Dim lcx As AcadLayer
Set lcx = ThisDrawing.Layers.Add("虚线层")
lcx.Color = acCyan
On Error Resume Next
Do
If IsEmpty(zbd1) Then
zbd = ThisDrawing.Utility.GetPoint(, "第一点：")
Else
zbd = ThisDrawing.Utility.GetPoint(zbd1, "下一点：")
End If
If Err Then
Err.Clear
Exit Do
End If
ReDim Preserve blist(3 * i + 2)
blist(3 * i) = zbd(0): blist(3 * i + 1) = zbd(1): blist(3 * i + 2) = zbd(2)
i = i + 1
If i = 1 Then
GoTo ppp
End If
If i = 2 Then
Dim start(0 To 5) As Double
start(0) = zbd1(0)
start(1) = zbd1(1)
start(2) = zbd1(2)
start(3) = zbd(0)
start(4) = zbd(1)
start(5) = zbd(2)
Set fzpl = ThisDrawing.ModelSpace.AddPolyline(start)
fzpl.Linetype = "acad_iso05w100"
fzpl.Layer = "虚线层"
fzpl.Update
GoTo ppp
End If
fzpl.Coordinates = blist
fzpl.Update
ppp:
zbd1 = zbd
Loop
fzpl.Coordinates = blist
End Sub
非常好，感谢topirol的热心帮助！！！ 真的比偶作的简单多了~~~~~
偶地代码就不好意思贴了~~~ 再有闭合和回退功能就更完善了！谢谢topiro！!
还请有空完善。
那就再完善一下，看看代码
本帖最后由 作者 于 2003-11-27 12:30:52 编辑功能可以实现，不过我觉得代码不是很好，将就吧，希望有人再来完善一下
Sub kkk1()
Dim entry As AcadLineType
Dim found As Boolean
found = False
For Each entry In ThisDrawing.Linetypes
If StrComp(entry.Name, "acad_iso05w100", 1) = 0 Then
found = True
Exit For
End If
Next
If Not (found) Then ThisDrawing.Linetypes.Load "acad_iso05w100", "acadiso.lin"
Dim fzpl As AcadPolyline
Dim zbd As Variant
Dim zbd1 As Variant
Dim startpoint As Variant
Dim i As Integer
Dim j As Integer
Dim blist() As Double
Dim lcx As AcadLayer
Set lcx = ThisDrawing.Layers.Add("虚线层")
lcx.Color = acCyan
On Error Resume Next
Dim keywordList As String
keywordList = "Close Undo"
Do
If IsEmpty(zbd1) Then
zbd = ThisDrawing.Utility.GetPoint(, "第一点:")
startpoint = zbd
Else
restart:
ThisDrawing.Utility.InitializeUserInput 128, keywordList
zbd = ThisDrawing.Utility.GetPoint(zbd1, "下一点[闭合(C)/后退(U)]:")
If Err Then
If Err.Number = -2147467259 Then
Dim inputString As String
Err.Clear
inputString = ThisDrawing.Utility.GetInput
If inputString = "Close" Then
fzpl.Closed = True
End If
If inputString = "Undo" Then
i = i - 2
If i = 0 Then
fzpl.Delete
zbd1 = startpoint
blist(0) = zbd1(0)
blist(1) = zbd1(1)
blist(2) = zbd1(2)
i = 1
GoTo restart
'End
End If
If i < 0 Then
End
End If
ReDim Preserve blist(3 * i + 2)
GoTo endundo
End If
Exit Do
End If
End If
End If
If Err Then
Err.Clear
Exit Do
End If
ReDim Preserve blist(3 * i + 2)
blist(3 * i) = zbd(0): blist(3 * i + 1) = zbd(1): blist(3 * i + 2) = zbd(2)
If i = 0 Then
zbd1 = zbd
GoTo ppploop
End If
If i = 1 Then
Dim start(0 To 5) As Double
start(0) = blist(0)
start(1) = blist(1)
start(2) = blist(2)
start(3) = blist(3)
start(4) = blist(4)
start(5) = blist(5)
Set fzpl = ThisDrawing.ModelSpace.AddPolyline(start)
fzpl.Linetype = "acad_iso05w100"
fzpl.Layer = "虚线层"
fzpl.Update
zbd1 = zbd
GoTo ppploop
End If
endundo:
fzpl.Coordinates = blist
fzpl.Update
j = (UBound(fzpl.Coordinates) + 1) / 3
zbd1 = fzpl.Coordinate(j - 1)
ppploop:
i = i + 1
Loop
fzpl.Coordinates = blist
End Sub
页:
[1]