求助！！区域内的多段线自动编号标注长度

TimeT

各位大侠：
小弟在处理图件的时候，遇到十分多的线需要编号（如A1，A2，A3。。。。)并且统计出个多段线的长度，工作量是否巨大，是故恳请各位大侠赐教，看是否能够自动对区域内的线自动编号（编号的顺序没有关系）并标注（或者统计）出相应线段的长度。
如图：


悬赏是个噱头，还望不弃！

x_s_s_1

试试，除MLINE其它任意曲线均可

2. ;;;BY X_S_S_1
   
3. (vl-load-com)
   
4. (defun c:test1 (/
   
5.                 ss
   
6.                 qz
   
7.                 lst
   
8.                 length_lst
   
9.                 en
   
10.                 pt_lst
    
11.                 curve-obj
    
12.                 dist
    
13.                 s_lst
    
14.                 n
    
15.                 pt
    
16.                 tl
    
17.                )
    
18.   (defun x_ssn (ss / n lst)
    
19.     (repeat (setq N (sslength ss))
    
20.       (setq LST (cons (ssname SS (setq N (1- N))) LST))
    
21.     )
    
22.   )
    
23.   (defun emk_t (layer pt1 pt2 text ang n72 n73 h /)
    
24.     (entmake (list '(0 . "text")
    
25.                    '(100 . "AcDbEntity")
    
26.                    (cons 8 layer)
    
27.                    '(100 . "AcDbText")
    
28.                    (cons 10 pt1)
    
29.                    (cons 1 text)
    
30.                    (cons 40 h)
    
31.                    '(41 . 0.75)
    
32.                    '(7 . "standard")
    
33.                    (cons 72 n72)
    
34.                    (cons 11 pt2)
    
35.                    (cons 50 ang)
    
36.                    (cons 73 n73)
    
37.              ) ;_ 结束list
    
38.     ) ;_ 结束entmake
    
39.   ) ;_ 结束defun
    
40.   (SETQ SS (SSGET '((0 . "*LINE,CIRCLE,ARC,ELLIPSE"))))
    
41.   (setq qz (getstring "\n前缀:"))
    
42.   (setq lst (x_ssn ss))
    
43.   (setq        length_lst
    
44.          (mapcar '(lambda (en)
    
45.                     (vlax-curve-getDistAtParam
    
46.                       en
    
47.                       (vlax-curve-getEndParam en)
    
48.                     )
    
49.                   )
    
50.                  lst
    
51.          )
    
52.   )
    
53.   (setq
    
54.     pt_lst (mapcar '(lambda (curve-obj dist)
    
55.                       (vlax-curve-getPointAtDist curve-obj (/ dist 2))
    
56.                     )
    
57.                    lst
    
58.                    length_lst
    
59.            )
    
60.   )
    
61.   (setq s_lst nil)
    
62.   (repeat (setq n (length length_lst))
    
63.     (setq s_lst        (cons (strcat qz
    
64.                               (itoa n)
    
65.                               "="
    
66.                               (rtos (nth (1- n) length_lst) 2 2)
    
67.                       )
    
68.                       s_lst
    
69.                 )
    
70.     )
    
71.     (setq n (1- n))
    
72.   )
    
73.   (mapcar '(lambda (pt tl) (emk_t "0" pt pt tl 0 1 0 250))
    
74.           pt_lst
    
75.           s_lst
    
76.   )
    
77. )
    

;;;BY X_S_S_1<br /> (vl-load-com)<br /> (defun c:test1 (/<br />                 ss<br />                 qz<br />                 lst<br />                 length_lst<br />                 en<br />                 pt_lst<br />                 curve-obj<br />                 dist<br />                 s_lst<br />                 n<br />                 pt<br />                 tl<br />                )<br />   (defun x_ssn (ss / n lst)<br />     (repeat (setq N (sslength ss))<br />       (setq LST (cons (ssname SS (setq N (1- N))) LST))<br />     )<br />   )<br />   (defun emk_t (layer pt1 pt2 text ang n72 n73 h /)<br />     (entmake (list '(0 . "text")<br />                    '(100 . "AcDbEntity")<br />                    (cons 8 layer)<br />                    '(100 . "AcDbText")<br />                    (cons 10 pt1)<br />                    (cons 1 text)<br />                    (cons 40 h)<br />                    '(41 . 0.75)<br />                    '(7 . "standard")<br />                    (cons 72 n72)<br />                    (cons 11 pt2)<br />                    (cons 50 ang)<br />                    (cons 73 n73)<br />              ) ;_ 结束list<br />     ) ;_ 结束entmake<br />   ) ;_ 结束defun<br />   (SETQ SS (SSGET '((0 . "*LINE,CIRCLE,ARC,ELLIPSE"))))<br />   (setq qz (getstring "\n前缀:"))<br />   (setq lst (x_ssn ss))<br />   (setq        length_lst<br />          (mapcar '(lambda (en)<br />                     (vlax-curve-getDistAtParam<br />                       en<br />                       (vlax-curve-getEndParam en)<br />                     )<br />                   )<br />                  lst<br />          )<br />   )<br />   (setq<br />     pt_lst (mapcar '(lambda (curve-obj dist)<br />                       (vlax-curve-getPointAtDist curve-obj (/ dist 2))<br />                     )<br />                    lst<br />                    length_lst<br />            )<br />   )<br />   (setq s_lst nil)<br />   (repeat (setq n (length length_lst))<br />     (setq s_lst        (cons (strcat qz<br />                               (itoa n)<br />                               "="<br />                               (rtos (nth (1- n) length_lst) 2 2)<br />                       )<br />                       s_lst<br />                 )<br />     )<br />     (setq n (1- n))<br />   )<br />   (mapcar '(lambda (pt tl) (emk_t "0" pt pt tl 0 1 0 250))<br />           pt_lst<br />           s_lst<br />   )<br /> )<br />

sscylh

2. Sub aa()
   
3. Dim ss As AcadSelectionSet
   
4. Dim lobj As AcadLine
   
5. Set ss = ThisDrawing.SelectionSets.Add(Rnd() & "abfc")
   
6. Dim filter(0) As Integer
   
7. Dim data(0) As Variant
   
8. Dim pt3(0 To 2) As Double
   
9. Dim l As Double
   
10. Dim pt1 As Variant
    
11. Dim pt2 As Variant
    
12. filter(0) = 0
    
13. data(0) = "line"
    
14. ss.SelectOnScreen filter, data
    
15. For i = 1 To ss.Count
    
16. Set lobj = ss(i - 1)
    
17. pt1 = lobj.StartPoint
    
18. pt2 = lobj.EndPoint
    
19. pt3(0) = (pt1(0) + pt2(0)) / 2
    
20. pt3(1) = (pt1(1) + pt2(1)) / 2
    
21. pt3(2) = 0
    
22. l = Round(lobj.Length, 2)
    
23. ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15
    
24. ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed
    
25. Next
    
26. End Sub

Sub aa()<br /> Dim ss As AcadSelectionSet<br /> Dim lobj As AcadLine<br /> Set ss = ThisDrawing.SelectionSets.Add(Rnd() & "abfc")<br /> Dim filter(0) As Integer<br /> Dim data(0) As Variant<br /> Dim pt3(0 To 2) As Double<br /> Dim l As Double<br /> Dim pt1 As Variant<br /> Dim pt2 As Variant<br /> filter(0) = 0<br /> data(0) = "line"<br /> ss.SelectOnScreen filter, data<br /> For i = 1 To ss.Count<br /> Set lobj = ss(i - 1)<br /> pt1 = lobj.StartPoint<br /> pt2 = lobj.EndPoint<br /> pt3(0) = (pt1(0) + pt2(0)) / 2<br /> pt3(1) = (pt1(1) + pt2(1)) / 2<br /> pt3(2) = 0<br /> l = Round(lobj.Length, 2)<br /> ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15<br /> ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed<br /> Next<br /> End Sub

TimeT

sscylh 发表于 2012-9-24 23:21

谢谢大侠
但是现在这个好像只能选择直线而我的全是多段线，劳大侠在费心下

革天明

TimeT 发表于 2012-9-25 09:22
谢谢大侠
但是现在这个好像只能选择直线而我的全是多段线，劳大侠在费心下

多段线的有点难，因为里面还有圆弧什么的，长度不好计算

sscylh

革天明 发表于 2012-9-25 16:37
多段线的有点难，因为里面还有圆弧什么的，长度不好计算

不会,长度可以直接调用其属性得到,不需要计算
对了,你的那个问题怎么样了?解决了吗?还有什么不对的吗?

sscylh

2. Sub aa()
   
3. Dim ss As AcadSelectionSet
   
4. Dim lobj As AcadLine
   
5. Dim lwobj As AcadLWPolyline
   
6. Set ss = ThisDrawing.SelectionSets.Add(Rnd() & "abff8FDdffddc")
   
7. Dim filter(0 To 3) As Integer
   
8. Dim data(0 To 3) As Variant
   
9. Dim pt3(0 To 2) As Double
   
10. Dim l As Double
    
11. Dim pt1 As Variant
    
12. Dim pt2 As Variant
    
13. filter(0) = -4
    
14. data(0) = "<or"
    
15. filter(1) = 0
    
16. data(1) = "line"
    
17. filter(2) = 0
    
18. data(2) = "lwpolyline"
    
19. filter(3) = -4
    
20. data(3) = "or>"
    
21. ss.SelectOnScreen filter, data
    
22. For i = 1 To ss.Count
    
23. If ss(i - 1).ObjectName = "AcDbLine" Then
    
24. Set lobj = ss(i - 1)
    
25. pt1 = lobj.StartPoint
    
26. pt2 = lobj.EndPoint
    
27. pt3(0) = (pt1(0) + pt2(0)) / 2
    
28. pt3(1) = (pt1(1) + pt2(1)) / 2
    
29. pt3(2) = 0
    
30. l = Round(lobj.Length, 2)
    
31. ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15
    
32. ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed
    
33. ElseIf ss(i - 1).ObjectName = "AcDbPolyline" Then
    
34. Set lwobj = ss(i - 1)
    
35. pt1 = lwobj.Coordinate(0)
    
36. pt2 = lwobj.Coordinate(1)
    
37. pt3(0) = (pt1(0) + pt2(0)) / 2
    
38. pt3(1) = (pt1(1) + pt2(1)) / 2
    
39. pt3(2) = 0
    
40. l = Round(lwobj.Length, 2)
    
41. ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15
    
42. ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed
    
43. End If
    
44. Next
    
45. End Sub
    

Sub aa()<br /> Dim ss As AcadSelectionSet<br /> Dim lobj As AcadLine<br /> Dim lwobj As AcadLWPolyline<br /> Set ss = ThisDrawing.SelectionSets.Add(Rnd() & "abff8FDdffddc")<br /> Dim filter(0 To 3) As Integer<br /> Dim data(0 To 3) As Variant<br /> Dim pt3(0 To 2) As Double<br /> Dim l As Double<br /> Dim pt1 As Variant<br /> Dim pt2 As Variant<br /> filter(0) = -4<br /> data(0) = "<or"<br /> filter(1) = 0<br /> data(1) = "line"<br /> filter(2) = 0<br /> data(2) = "lwpolyline"<br /> filter(3) = -4<br /> data(3) = "or>"<br /> ss.SelectOnScreen filter, data<br /> For i = 1 To ss.Count<br /> If ss(i - 1).ObjectName = "AcDbLine" Then<br /> Set lobj = ss(i - 1)<br /> pt1 = lobj.StartPoint<br /> pt2 = lobj.EndPoint<br /> pt3(0) = (pt1(0) + pt2(0)) / 2<br /> pt3(1) = (pt1(1) + pt2(1)) / 2<br /> pt3(2) = 0<br /> l = Round(lobj.Length, 2)<br /> ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15<br /> ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed<br /> ElseIf ss(i - 1).ObjectName = "AcDbPolyline" Then<br /> Set lwobj = ss(i - 1)<br /> pt1 = lwobj.Coordinate(0)<br /> pt2 = lwobj.Coordinate(1)<br /> pt3(0) = (pt1(0) + pt2(0)) / 2<br /> pt3(1) = (pt1(1) + pt2(1)) / 2<br /> pt3(2) = 0<br /> l = Round(lwobj.Length, 2)<br /> ThisDrawing.ModelSpace.AddText "a" & i & "=" & l, pt3, l / 15<br /> ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1).color = acRed<br /> End If<br /> Next<br /> End Sub<br />

TimeT

谢谢各位大侠！小弟还是要继续加强学习，不能一直做伸手党，很是汗颜。

jack11280

真的很好用耶可以增加文字大小的选项

六千棵橡树V

很实用的一个工具！赞！