|
|
'怎样拟合下面程序建立的多段线
' 获得用户输入的宽度值
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)]:")
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
|
|
置顶卡
