关于景观树木的标注

Lisphk

看到过这样一个插件，可惜找不到程序，只有演示，能否编一个？谢谢！

newer

简单写了个，字体高度什么的可以自己修改代码

1. (defun c:tt ()
   
2.   (xdrx_begin '(("osmode" 0)))
   
3.   (if (and
   
4.         (setq e (xdrx_entsel "\n选取样本树<退出>:" '((0 . "insert"))))
   
5.         (setq pts (XD::Doc:GetFence "\n起始点" "\n下一点<结束>" -1))
   
6.         (setq e (car e)
   
7.               blkna (car (xdrx_getpropertyvalue e "blocktablerecord"))
   
8.         )
   
9.         (setq ss (ssget "f" pts (list '(0 . "insert") (cons 2 blkna))))
   
10.       )
    
11.     (progn
    
12.       (if (> (sslength ss) 1)
    
13.         (progn
    
14.           (setq ptj (mapcar
    
15.                       '(lambda (x)
    
16.                          (xdrx_getpropertyvalue x "position")
    
17.                        )
    
18.                       (xdrx_pickset->ents ss)
    
19.                     )
    
20.           )
    
21.           (setq e (apply
    
22.                     'xdrx_polyline_make
    
23.                     pts
    
24.                   )
    
25.           )
    
26.           (setq ptj1 (xdrx_points_sortOnCurve e ptj)
    
27.                 ptj2 (mapcar
    
28.                        'cadr
    
29.                        ptj1
    
30.                      )
    
31.           )
    
32.           (entdel e)
    
33.           (apply
    
34.             'xdrx_polyline_make
    
35.             ptj2
    
36.           )
    
37.         )
    
38.         (progn
    
39.         )
    
40.       )
    
41.       (setq pt (getpoint (last ptj2) "\n标注位置："))
    
42.       (setq e (xdrx_mleader_make (last ptj2) pt (strcat blkna (itoa
    
43.                                                                     (sslength ss)
    
44.                                                               ) "株"
    
45.                                                 ) 40.0
    
46.               )
    
47.       )
    
48.       (xdrx_setpropertyvalue e "ArrowSymbolId" "_none" "DoglegLength" 20.0
    
49.                              "TextAttachmentType" 5
    
50.       )
    
51.     )
    
52.   )
    
53.   (xdrx_end)
    
54.   (princ)
    
55. )
    
56. 
    

(defun c:tt ()<br />   (xdrx_begin '(("osmode" 0)))<br />   (if (and<br />         (setq e (xdrx_entsel "\n选取样本树<退出>:" '((0 . "insert"))))<br />         (setq pts (XD::Doc:GetFence "\n起始点" "\n下一点<结束>" -1))<br />         (setq e (car e)<br />               blkna (car (xdrx_getpropertyvalue e "blocktablerecord"))<br />         )<br />         (setq ss (ssget "f" pts (list '(0 . "insert") (cons 2 blkna))))<br />       )<br />     (progn<br />       (if (> (sslength ss) 1)<br />         (progn<br />           (setq ptj (mapcar<br />                       '(lambda (x)<br />                          (xdrx_getpropertyvalue x "position")<br />                        )<br />                       (xdrx_pickset->ents ss)<br />                     )<br />           )<br />           (setq e (apply<br />                     'xdrx_polyline_make<br />                     pts<br />                   )<br />           )<br />           (setq ptj1 (xdrx_points_sortOnCurve e ptj)<br />                 ptj2 (mapcar<br />                        'cadr<br />                        ptj1<br />                      )<br />           )<br />           (entdel e)<br />           (apply<br />             'xdrx_polyline_make<br />             ptj2<br />           )<br />         )<br />         (progn<br />         )<br />       )<br />       (setq pt (getpoint (last ptj2) "\n标注位置："))<br />       (setq e (xdrx_mleader_make (last ptj2) pt (strcat blkna (itoa<br />                                                                     (sslength ss)<br />                                                               ) "株"<br />                                                 ) 40.0<br />               )<br />       )<br />       (xdrx_setpropertyvalue e "ArrowSymbolId" "_none" "DoglegLength" 20.0<br />                              "TextAttachmentType" 5<br />       )<br />     )<br />   )<br />   (xdrx_end)<br />   (princ)<br /> )<br /> <br />

newer

是不是一种树中间还有可能有其*他类型的树啊？如果这样，直线拉选择就歧义了。

Lisphk

newer 发表于 2016-4-14 10:50
是不是一种树中间还有可能有其*他类型的树啊？如果这样，直线拉选择就歧义了。

是的，大师，是有可能，如果能过滤掉不需要的那更方便了。

倾斜的水平

有一个科创易达的，可惜是收费的。

newer

说明下，块名作为标注的文字加上数量
程序只连接样本树的插入点。过滤掉不是样本块的**图块。

newer

对了，安装晓东工具箱后，把代码加载到CAD里面命令TT即可。

Lisphk

newer 发表于 2016-4-14 14:23
对了，安装晓东工具箱后，把代码加载到CAD里面命令TT即可。

谢谢N版了，太好了，完美。试了下，发现往左边标的时候字下没线，在引线的中间了，希望能修改下就更完美了。

csharp

Lisphk 发表于 2016-4-14 15:37
谢谢N版了，太好了，完美。试了下，发现往左边标的时候字下没线，在引线的中间了，希望能修改下就更完美 ...

楼主试试这个框选自动连线，函数是“模拟退火算法"，编译文件是 For AutoCAD 2010-2012 x86 和 x64

2. 
   
3. (defun c:tt (/ ss sl e pts ptl pl _AddMleader sp ml pl)
   
4.   (defun _AddMleader (p1 p2 str / ml)
   
5.     (setq ml (vlax-invoke
   
6.                (vla-get-modelspace
   
7.                  (vla-get-activedocument (vlax-get-acad-object))
   
8.                )
   
9.                'AddMleader
   
10.                (append p1 p2)
    
11.                0
    
12.              )
    
13.     )
    
14.     (vla-put-DoglegLength ml 0.0)
    
15.     (vla-put-textleftattachmenttype ml 3)
    
16.     (vla-put-textrightattachmenttype ml 3)
    
17.     (vla-put-textstring ml str)
    
18.     (vla-put-LandingGap ml 0.0)
    
19.     (vla-put-textrotation ml 0.0)
    
20.     (vla-put-TextLineSpacingFactor ml 0.8)
    
21.     (vla-put-TextLineSpacingStyle ml 1)
    
22.     (vla-put-TextJustify ml 2)
    
23.     (vla-put-DogLegged ml -1)
    
24.     (vla-put-ContentType ml 2)
    
25.     ml
    
26.   )
    
27.   (if (setq ss (ssget '((0 . "insert"))))
    
28.     (progn
    
29.       (setq sl (sslength ss))
    
30.       (while (setq e (ssname ss (setq sl (1- sl))))
    
31.         (setq pts (cons (cdr (assoc 10 (entget e))) pts))
    
32.       )
    
33.       (setq ptl        (tsaa pts)
    
34.             sp        (car ptl)
    
35.             pl        (vlax-invoke (vla-get-modelspace
    
36.                                (vla-get-activedocument (vlax-get-acad-object))
    
37.                              )
    
38.                              'AddLightWeightPolyline
    
39.                              (apply 'append ptl)
    
40.                 )
    
41.             sp        (list (car sp) (cadr sp) 0.0)
    
42.             ml        (_AddMleader sp
    
43.                              (polar sp (* pi 0.25) 100.0);_转点位置
    
44.                              (cdr (assoc 2 (entget (ssname ss 0))))
    
45.                 )
    
46.       )
    
47.       (vla-put-ArrowheadBlock ml "_NONE");_取消箭头
    
48.       (vla-put-textheight ml 100.0);_文字高度
    
49.     )
    
50.   )
    
51.   (princ)
    
52. )

<br /> (defun c:tt (/ ss sl e pts ptl pl _AddMleader sp ml pl)<br />   (defun _AddMleader (p1 p2 str / ml)<br />     (setq ml (vlax-invoke<br />                (vla-get-modelspace<br />                  (vla-get-activedocument (vlax-get-acad-object))<br />                )<br />                'AddMleader<br />                (append p1 p2)<br />                0<br />              )<br />     )<br />     (vla-put-DoglegLength ml 0.0)<br />     (vla-put-textleftattachmenttype ml 3)<br />     (vla-put-textrightattachmenttype ml 3)<br />     (vla-put-textstring ml str)<br />     (vla-put-LandingGap ml 0.0)<br />     (vla-put-textrotation ml 0.0)<br />     (vla-put-TextLineSpacingFactor ml 0.8)<br />     (vla-put-TextLineSpacingStyle ml 1)<br />     (vla-put-TextJustify ml 2)<br />     (vla-put-DogLegged ml -1)<br />     (vla-put-ContentType ml 2)<br />     ml<br />   )<br />   (if (setq ss (ssget '((0 . "insert"))))<br />     (progn<br />       (setq sl (sslength ss))<br />       (while (setq e (ssname ss (setq sl (1- sl))))<br />         (setq pts (cons (cdr (assoc 10 (entget e))) pts))<br />       )<br />       (setq ptl        (tsaa pts)<br />             sp        (car ptl)<br />             pl        (vlax-invoke (vla-get-modelspace<br />                                (vla-get-activedocument (vlax-get-acad-object))<br />                              )<br />                              'AddLightWeightPolyline<br />                              (apply 'append ptl)<br />                 )<br />             sp        (list (car sp) (cadr sp) 0.0)<br />             ml        (_AddMleader sp<br />                              (polar sp (* pi 0.25) 100.0);_转点位置<br />                              (cdr (assoc 2 (entget (ssname ss 0))))<br />                 )<br />       )<br />       (vla-put-ArrowheadBlock ml "_NONE");_取消箭头<br />       (vla-put-textheight ml 100.0);_文字高度<br />     )<br />   )<br />   (princ)<br /> )

newer

csharp 发表于 2016-4-17 20:03
楼主试试这个框选自动连线，函数是“模拟退火算法"，编译文件是 For AutoCAD 2010-2012 x86 和 x64

UCS下，MLEADER的文字是平行X轴吗？在不同的图块在一起的时候，框选并不高效，另外连线的顺序是按照什么规则？

csharp

newer 发表于 2016-4-17 21:13
UCS下，MLEADER的文字是平行X轴吗？在不同的图块在一起的时候，框选并不高效，另外连线的顺序是按照什么 ...

可以加上点选样本，然后再框选过滤

这个算法每次运算结果可能不一样，非最优解

iLisp

newer 发表于 2016-4-17 21:13
UCS下，MLEADER的文字是平行X轴吗？在不同的图块在一起的时候，框选并不高效，另外连线的顺序是按照什么 ...

代码已更新，文字平行 UCS X轴

模拟退火算法的一个介绍
http://www.cnblogs.com/heaad/archive/2010/12/20/1911614.html