lzhr4u 发表于 2006-3-28 23:37:00

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

<P>'怎样拟合下面程序建立的多段线</P>
<P>' 获得用户输入的宽度值<BR>Public Function GetWidth() As Double<BR>On Error Resume Next<BR>Dim width As Double<BR>width = ThisDrawing.Utility.GetReal("输入线宽:")<BR>If err Then width = -1<BR>GetWidth = width<BR>End Function</P>
<P>' 获得用户输入的颜色索引值<BR>Public Function GetColorIndex() As Integer<BR>On Error Resume Next<BR>Dim colorIndex As Integer<BR>colorIndex = ThisDrawing.Utility.GetInteger("输入颜色索引值:")<BR>If err Then<BR>colorIndex = -1<BR>End If</P>
<P>&nbsp;&nbsp;&nbsp; GetColorIndex = colorIndex<BR>&nbsp;&nbsp;&nbsp; End Function</P>
<P>' 模拟创建多段线的过程<BR>Public Sub CreatePolyline()<BR>On Error Resume Next<BR>Dim colorIndex As Integer&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 多段线的颜色索引号<BR>Dim width As Double&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 多段线的线宽<BR>colorIndex = 0<BR>width = 0<BR>Dim index As Integer&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 当前输入点的次数<BR>index = 2&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 提示用户输入第一点<BR>Dim pt1 As Variant<BR>pt1 = ThisDrawing.Utility.GetPoint(, "输入第一点:")<BR>If err Then<BR>err.Clear<BR>Exit Sub<BR>End If</P>
<P>&nbsp;&nbsp;&nbsp; Dim ptPrevious As Variant, ptCurrent As Variant&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 拾取点过程中，存储上一点和当前点的变量<BR>&nbsp;&nbsp;&nbsp; ptPrevious = pt1&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 定义有效的关键字<BR>&nbsp;&nbsp;&nbsp; Dim strKeyWords As String<BR>&nbsp;&nbsp;&nbsp; strKeyWords = "W C O"</P>
<P>NEXTPOINT:&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 设置关键字<BR>ThisDrawing.Utility.InitializeUserInput 128, strKeyWords<BR>ptCurrent = ThisDrawing.Utility.GetPoint(ptPrevious, "输入下一点 [宽度(W)/颜色(C)]&lt;完成(O)&gt;:")<BR>If err Then&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 在错误处理中判断用户输入的关键字<BR>If StrComp(err.Description, "用户输入的是关键字", 1) = 0 Then<BR>Dim strInput As String<BR>strInput = ThisDrawing.Utility.GetInput<BR>err.Clear&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 根据输入的关键字进行相应的处理<BR>If StrComp(strInput, "W", vbTextCompare) = 0 Then&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 获得用户输入的宽度值<BR>width = GetWidth<BR>GoTo NEXTPOINT<BR>ElseIf StrComp(strInput, "C", vbTextCompare) = 0 Then&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 获得用户输入的颜色索引值<BR>colorIndex = GetColorIndex<BR>GoTo NEXTPOINT<BR>ElseIf StrComp(strInput, "O", vbTextCompare) = 0 Or Len(strInput) = 0 Then&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 完成多段线的创建</P>
<P>'ThisDrawing.SendCommand "_Pedit" &amp; vbCr &amp; "m" &amp; vbCr &amp; vbCr &amp; "f" &amp; vbCr &amp; vbCr</P>
<P><BR>Exit Sub<BR>End If<BR>Else<BR>err.Clear<BR>End If<BR>End If<BR>Dim objPLine As AcadLWPolyline<BR>If index = 2 Then&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 创建多段线<BR>Dim points(0 To 3) As Double<BR>points(0) = ptPrevious(0)<BR>points(1) = ptPrevious(1)<BR>points(2) = ptCurrent(0)<BR>points(3) = ptCurrent(1)<BR>Set objPLine = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)<BR>ElseIf index &gt; 2 Then<BR>Dim ptVert(0 To 1) As Double<BR>ptVert(0) = ptCurrent(0)<BR>ptVert(1) = ptCurrent(1)<BR>objPLine.AddVertex index - 1, ptVert<BR>End If&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp; ' 修改多段线的线宽和颜色<BR>If width &lt;&gt; -1 Then<BR>objPLine.ConstantWidth = width<BR>End If<BR>If colorIndex &lt;&gt; -1 Then<BR>Dim color As New AcadAcCmColor<BR>color.colorIndex = colorIndex<BR>objPLine.TrueColor = color<BR>End If<BR>index = index + 1<BR>ptPrevious = ptCurrent</P>
<P>&nbsp;&nbsp;&nbsp; GoTo NEXTPOINT</P>
<P>End Sub</P>

mccad 发表于 2006-4-1 18:03:00

只能用SendCommand来完成。

amanwang 发表于 2006-4-17 23:15:00

<P>很好的.</P>
页: [1]
查看完整版本: 求助：多段线的拟合问题 ！！！！