如何计算指定线加总长度？

supercorn

如何计算指定线加总长度？



可以选定N条线（直线、曲线、多线段、圆弧......），然后计算它们的长度和。

雪山飞狐_lzh

看看置顶的Vlax类

o_o

工具－查询－列表显示


可以显示每条线的长度

zxli2004

顶一下，VBA怎么实现？

dchlmz

直线可以用length取得，其它通过取得坐标计算线长，累加就行了

zxli2004

这样是不是对spline的精度偏差较大？


length只能对Line和Arc有效。

zxli2004

急，我再顶！

mccad

3. Sub GetSelectCurveLength()
4.        Dim SS As AcadSelectionSet
5.        Set SS = CreateSelectionSet
6.        Dim varType As Variant
7.        Dim varData As Variant
8.        BuildFilter varType, varData, 0, _
9.                              "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE"
10.        SS.SelectOnScreen varType, varData
11.        Dim objEntity As AcadEntity
12.        Dim dblLength As Double
13.        For Each objEntity In SS
14.                dblLength = dblLength + GetCurveLength(objEntity)
15.        Next
16.        MsgBox "所选曲线的总长度为 " & dblLength, , "明经通道VBA示例"
17. End Sub
18. Public Function GetCurveLength(curve As AcadEntity) As Double
19.        Dim obj As VLAX, retVal
20.       
21.        Set obj = New VLAX
22.       
23.        obj.EvalLispExpression "(setq curve (handent " & Chr(34) & curve.Handle & Chr(34) & "))"
24.        obj.EvalLispExpression "(setq curvelength (vlax-curve-getDistAtParam curve " & _
25.                                                      "(vlax-curve-getEndParam curve)))"
26.        retVal = obj.GetLispSymbol("curvelength")
27.        obj.NullifySymbol "curve", "curvelength"
28.       
29.        '释放内存，函数返回
30.        Set obj = Nothing
31.        GetCurveLength = CDbl(retVal)
32. End Function
33. Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
34.        Dim fType() As Integer, fData()
35.        Dim index As Long, i As Long
36.       
37.        index = LBound(gCodes) - 1
38.                
39.        For i = LBound(gCodes) To UBound(gCodes) Step 2
40.                index = index + 1
41.                ReDim Preserve fType(0 To index)
42.                ReDim Preserve fData(0 To index)
43.                fType(index) = CInt(gCodes(i))
44.                fData(index) = gCodes(i + 1)
45.        Next
46.        typeArray = fType: dataArray = fData
47. End Sub
48. Function CreateSelectionSet(Optional SSetName As String = "mjtd") As AcadSelectionSet
49.        On Error Resume Next
50.        ThisDrawing.SelectionSets(SSetName).Delete
51.        Set CreateSelectionSet = ThisDrawing.SelectionSets.Add(SSetName)
52. End Function

Sub GetSelectCurveLength()        Dim SS As AcadSelectionSet        Set SS = CreateSelectionSet        Dim varType As Variant        Dim varData As Variant        BuildFilter varType, varData, 0, _                              "ARC,CIRCLE,ELLIPSE,LINE,LWPOLYLINE,POLYLINE,SPLINE"        SS.SelectOnScreen varType, varData        Dim objEntity As AcadEntity        Dim dblLength As Double        For Each objEntity In SS                dblLength = dblLength + GetCurveLength(objEntity)        Next        MsgBox "所选曲线的总长度为 " & dblLength, , "明经通道VBA示例" End Sub Public Function GetCurveLength(curve As AcadEntity) As Double        Dim obj As VLAX, retVal               Set obj = New VLAX               obj.EvalLispExpression "(setq curve (handent " & Chr(34) & curve.Handle & Chr(34) & "))"        obj.EvalLispExpression "(setq curvelength (vlax-curve-getDistAtParam curve " & _                                                      "(vlax-curve-getEndParam curve)))"        retVal = obj.GetLispSymbol("curvelength")        obj.NullifySymbol "curve", "curvelength"               '释放内存，函数返回        Set obj = Nothing        GetCurveLength = CDbl(retVal) End Function Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())        Dim fType() As Integer, fData()        Dim index As Long, i As Long               index = LBound(gCodes) - 1                        For i = LBound(gCodes) To UBound(gCodes) Step 2                index = index + 1                ReDim Preserve fType(0 To index)                ReDim Preserve fData(0 To index)                fType(index) = CInt(gCodes(i))                fData(index) = gCodes(i + 1)        Next        typeArray = fType: dataArray = fData End Sub Function CreateSelectionSet(Optional SSetName As String = "mjtd") As AcadSelectionSet        On Error Resume Next        ThisDrawing.SelectionSets(SSetName).Delete        Set CreateSelectionSet = ThisDrawing.SelectionSets.Add(SSetName) End Function

zxli2004

Dim obj As VLAX, retVal

Set obj = New VLAX
？？？？？？？？？？？？是不是少东西？ 我不太懂，请多指教。谢谢!!

mccad

二楼不是已经说过了，用VLAX类，请查看置顶贴子。