获得多段线分段长度的vba
<p><font face="Verdana">我们知道 对象的长度可以用 object.length 获得，但是对于多段线，只能获得合计的长度，如何显示每段的长度呢。这是我的小程序，希望对大家有帮助。</font></p><p> </p>
<p><font face="Verdana">Function PLinelength(ent As AcadEntity) As String<br/>On Error GoTo errHandle<br/>Dim i As Integer<br/>Dim myPointSta As Variant, myPointEnd As Variant<br/>Dim myLength As Double</font></p>
<p><font face="Verdana">i = 1<br/>myPointSta = ent.Coordinate(0)</font></p><font face="Verdana">
<p> Do<br/>myPointEnd = ent.Coordinate(i)<br/>myLength = VBA.Sqr((myPointSta(0) - myPointEnd(0)) ^ 2 + (myPointSta(1) - myPointEnd(1)) ^ 2)</p>
<p> </p>
<p>myPointSta = myPointEnd<br/>PLinelength = IIf(PLinelength = "", myLength, PLinelength & "+" & myLength)<br/>i = i + 1<br/>Loop Until Err</p>
<p>errHandle:<br/><br/>End Function</p>
<p> </p>
<p><font face="Verdana">Sub 测试程序()</font></p>
<p><font face="Verdana">'////////////////////////////////////////////////<br/> Dim ssetObj As AcadSelectionSet<br/> Dim tCONUT As Integer<br/> tCONUT = 0<br/> tCONUT = ThisDrawing.SelectionSets.Count<br/> For ti = 0 To tCONUT - 1 '删除所有的选择集<br/> Set ssetObj = ThisDrawing.SelectionSets.Item(0)<br/> ssetObj.Delete<br/> Next ti</font></p>
<p><font face="Verdana">'//////////////////////////////////////////////////<br/>Set sel = ThisDrawing.SelectionSets.Add("ssel") </font></p>
<p><font face="Verdana">If Err Then<br/>Err.Clear<br/>Set sel = ThisDrawing.SelectionSets.Item("ssel") </font></p>
<p><font face="Verdana">End If<br/><br/>Lab_star:</font></p>
<p><font face="Verdana">sel.SelectOnScreen</font></p>
<p><font face="Verdana">Dim ent As AcadEntity<br/><br/>For Each ent In sel<br/></font></p><font face="Verdana">
<p>MsgBox PLinelength(ent)<br/>Next ent</p>
<p><br/>End Sub</font></p>
<p><font face="Verdana"></font></font> </p> 有圆弧段的结果不正确。 <p>自己顶一下</p> 顶起来，我也不太会 好的兄弟，有志气 我想要一个lisp的获得多段线的分段长度 我也想要一个lisp的获得多段线的分段长度！呵呵希望有人提供！ 有圆弧段的结果不正确。 yshf 发表于 2011-11-11 20:44 static/image/common/back.gif
有圆弧段的结果不正确。
看来算法要改进 你有什么好办法 当多段线中有某段为圆弧时，其凸度（弓高/半弦长）不为零，由此可得到半径、圆心角，也就能得到该段的长度。 先学习一下
页:
[1]
2