求助！！区域内的多段线自动编号标注长度
各位大侠：小弟在处理图件的时候，遇到十分多的线需要编号（如A1，A2，A3。。。。)并且统计出个多段线的长度，工作量是否巨大，是故恳请各位大侠赐教，看是否能够自动对区域内的线自动编号（编号的顺序没有关系）并标注（或者统计）出相应线段的长度。
如图：
悬赏是个噱头，还望不弃！
本帖最后由 x_s_s_1 于 2012-9-25 20:27 编辑
试试，除MLINE其它任意曲线均可
;;;BY X_S_S_1
(vl-load-com)
(defun c:test1 (/
ss
qz
lst
length_lst
en
pt_lst
curve-obj
dist
s_lst
n
pt
tl
)
(defun x_ssn (ss / n lst)
(repeat (setq N (sslength ss))
(setq LST (cons (ssname SS (setq N (1- N))) LST))
)
)
(defun emk_t (layer pt1 pt2 text ang n72 n73 h /)
(entmake (list '(0 . "text")
'(100 . "AcDbEntity")
(cons 8 layer)
'(100 . "AcDbText")
(cons 10 pt1)
(cons 1 text)
(cons 40 h)
'(41 . 0.75)
'(7 . "standard")
(cons 72 n72)
(cons 11 pt2)
(cons 50 ang)
(cons 73 n73)
) ;_ 结束list
) ;_ 结束entmake
) ;_ 结束defun
(SETQ SS (SSGET '((0 . "*LINE,CIRCLE,ARC,ELLIPSE"))))
(setq qz (getstring "\n前缀:"))
(setq lst (x_ssn ss))
(setq length_lst
(mapcar '(lambda (en)
(vlax-curve-getDistAtParam
en
(vlax-curve-getEndParam en)
)
)
lst
)
)
(setq
pt_lst (mapcar '(lambda (curve-obj dist)
(vlax-curve-getPointAtDist curve-obj (/ dist 2))
)
lst
length_lst
)
)
(setq s_lst nil)
(repeat (setq n (length length_lst))
(setq s_lst (cons (strcat qz
(itoa n)
"="
(rtos (nth (1- n) length_lst) 2 2)
)
s_lst
)
)
(setq n (1- n))
)
(mapcar '(lambda (pt tl) (emk_t "0" pt pt tl 0 1 0 250))
pt_lst
s_lst
)
)
Sub aa()
Dim ss As AcadSelectionSet
Dim lobj As AcadLine
Set ss = ThisDrawing.SelectionSets.Add(Rnd() & "abfc")
Dim filter(0) As Integer
Dim data(0) As Variant
Dim pt3(0 To 2) As Double
Dim l As Double
Dim pt1 As Variant
Dim pt2 As Variant
filter(0) = 0
data(0) = "line"
ss.SelectOnScreen filter, data
For i = 1 To ss.Count
Set lobj = ss(i - 1)
pt1 = lobj.StartPoint
pt2 = lobj.EndPoint
pt3(0) = (pt1(0) + pt2(0)) / 2
pt3(1) = (pt1(1) + pt2(1)) / 2
pt3(2) = 0
l = Round(lobj.Length, 2)
ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15
ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed
Next
End Sub sscylh 发表于 2012-9-24 23:21 static/image/common/back.gif
谢谢大侠
但是现在这个好像只能选择直线而我的全是多段线，劳大侠在费心下 TimeT 发表于 2012-9-25 09:22 static/image/common/back.gif
谢谢大侠
但是现在这个好像只能选择直线而我的全是多段线，劳大侠在费心下
多段线的有点难，因为里面还有圆弧什么的，长度不好计算 革天明 发表于 2012-9-25 16:37 static/image/common/back.gif
多段线的有点难，因为里面还有圆弧什么的，长度不好计算
不会,长度可以直接调用其属性得到,不需要计算
对了,你的那个问题怎么样了?解决了吗?还有什么不对的吗? Sub aa()
Dim ss As AcadSelectionSet
Dim lobj As AcadLine
Dim lwobj As AcadLWPolyline
Set ss = ThisDrawing.SelectionSets.Add(Rnd() & "abff8FDdffddc")
Dim filter(0 To 3) As Integer
Dim data(0 To 3) As Variant
Dim pt3(0 To 2) As Double
Dim l As Double
Dim pt1 As Variant
Dim pt2 As Variant
filter(0) = -4
data(0) = "<or"
filter(1) = 0
data(1) = "line"
filter(2) = 0
data(2) = "lwpolyline"
filter(3) = -4
data(3) = "or>"
ss.SelectOnScreen filter, data
For i = 1 To ss.Count
If ss(i - 1).ObjectName = "AcDbLine" Then
Set lobj = ss(i - 1)
pt1 = lobj.StartPoint
pt2 = lobj.EndPoint
pt3(0) = (pt1(0) + pt2(0)) / 2
pt3(1) = (pt1(1) + pt2(1)) / 2
pt3(2) = 0
l = Round(lobj.Length, 2)
ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15
ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed
ElseIf ss(i - 1).ObjectName = "AcDbPolyline" Then
Set lwobj = ss(i - 1)
pt1 = lwobj.Coordinate(0)
pt2 = lwobj.Coordinate(1)
pt3(0) = (pt1(0) + pt2(0)) / 2
pt3(1) = (pt1(1) + pt2(1)) / 2
pt3(2) = 0
l = Round(lwobj.Length, 2)
ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15
ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed
End If
Next
End Sub
本帖最后由 TimeT 于 2012-9-25 21:56 编辑
谢谢各位大侠！小弟还是要继续加强学习，不能一直做伸手党，很是汗颜。
真的很好用耶可以增加文字大小的选项 很实用的一个工具！赞！
页:
[1]
2