求助：多段线的拟合问题 ！！！！

lzhr4u

'怎样拟合下面程序建立的多段线

' 获得用户输入的宽度值
Public Function GetWidth() As Double
On Error Resume Next
Dim width As Double
width = ThisDrawing.Utility.GetReal("输入线宽:")
If err Then width = -1
GetWidth = width
End Function

' 获得用户输入的颜色索引值
Public Function GetColorIndex() As Integer
On Error Resume Next
Dim colorIndex As Integer
colorIndex = ThisDrawing.Utility.GetInteger("输入颜色索引值:")
If err Then
colorIndex = -1
End If

    GetColorIndex = colorIndex
    End Function

' 模拟创建多段线的过程
Public Sub CreatePolyline()
On Error Resume Next
Dim colorIndex As Integer       ' 多段线的颜色索引号
Dim width As Double             ' 多段线的线宽
colorIndex = 0
width = 0
Dim index As Integer            ' 当前输入点的次数
index = 2          ' 提示用户输入第一点
Dim pt1 As Variant
pt1 = ThisDrawing.Utility.GetPoint(, "输入第一点:")
If err Then
err.Clear
Exit Sub
End If

    Dim ptPrevious As Variant, ptCurrent As Variant         ' 拾取点过程中，存储上一点和当前点的变量
    ptPrevious = pt1          ' 定义有效的关键字
    Dim strKeyWords As String
    strKeyWords = "W C O"

NEXTPOINT:         ' 设置关键字
ThisDrawing.Utility.InitializeUserInput 128, strKeyWords
ptCurrent = ThisDrawing.Utility.GetPoint(ptPrevious, "输入下一点 [宽度(W)/颜色(C)]<完成(O)>:")
If err Then                 ' 在错误处理中判断用户输入的关键字
If StrComp(err.Description, "用户输入的是关键字", 1) = 0 Then
Dim strInput As String
strInput = ThisDrawing.Utility.GetInput
err.Clear                          ' 根据输入的关键字进行相应的处理
If StrComp(strInput, "W", vbTextCompare) = 0 Then                 ' 获得用户输入的宽度值
width = GetWidth
GoTo NEXTPOINT
ElseIf StrComp(strInput, "C", vbTextCompare) = 0 Then                 ' 获得用户输入的颜色索引值
colorIndex = GetColorIndex
GoTo NEXTPOINT
ElseIf StrComp(strInput, "O", vbTextCompare) = 0 Or Len(strInput) = 0 Then                 ' 完成多段线的创建

'ThisDrawing.SendCommand "_Pedit" & vbCr & "m" & vbCr & vbCr & "f" & vbCr & vbCr

Exit Sub
End If
Else
err.Clear
End If
End If
Dim objPLine As AcadLWPolyline
If index = 2 Then         ' 创建多段线
Dim points(0 To 3) As Double
points(0) = ptPrevious(0)
points(1) = ptPrevious(1)
points(2) = ptCurrent(0)
points(3) = ptCurrent(1)
Set objPLine = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
ElseIf index > 2 Then
Dim ptVert(0 To 1) As Double
ptVert(0) = ptCurrent(0)
ptVert(1) = ptCurrent(1)
objPLine.AddVertex index - 1, ptVert
End If          ' 修改多段线的线宽和颜色
If width <> -1 Then
objPLine.ConstantWidth = width
End If
If colorIndex <> -1 Then
Dim color As New AcadAcCmColor
color.colorIndex = colorIndex
objPLine.TrueColor = color
End If
index = index + 1
ptPrevious = ptCurrent

    GoTo NEXTPOINT

End Sub

mccad

只能用SendCommand来完成。

amanwang

很好的.