求助论坛高手帮忙编制一个批量标注CAD断面图超欠挖插件

lizhgang.jin

问题已解决

st788796

lizhgang.jin 发表于 2015-1-7 09:08
能否提供个完整的我再试试呢。

需要 XDAPI + xd-lisp-lib.vlx

1. (defun c:cqw (/ filter ss e1 e2 pActuals pDesigns pVertors pDists h sty)
   
2.   (setq        filter '((0 . "LWPOLYLINE")
   
3.                  (-4 . "&=")
   
4.                  (70 . 0)
   
5.                 )
   
6.   )
   
7.   (if (and (setq e1 (car (xdrx_entsel
   
8.                            "\n选择实际开挖线: "
   
9.                            (cons '(8 . "实际开挖线") filter)
   
10.                          )
    
11.                     )
    
12.            )
    
13.            (setq e2 (car (xdrx_entsel
    
14.                            "\n选择设计开挖线: "
    
15.                            (cons '(8 . "设计开挖线") filter)
    
16.                          )
    
17.                     )
    
18.            )
    
19.            (progn
    
20.              (if (not (xdrx_curve_direction e2)) ;_判断逆时针
    
21.                (xdrx_curve_reverse e2)
    
22.              )
    
23.              t
    
24.            )
    
25.       )
    
26.     (progn
    
27.       (setq pActuals (xdrx_getpropertyvalue e1 "Vertices") ;_实际开挖点
    
28.             pDesigns (mapcar '(lambda (x)
    
29.                                 (xdrx_curve_getclosestpoint e2 x)
    
30.                               )
    
31.                              pActuals
    
32.                      ) ;_对应设计点
    
33.             pVectors (mapcar
    
34.                        '(lambda        (x)
    
35.                           (mapcar '+
    
36.                                   x
    
37.                                   (xdrx_curve_getfirstderiv e2 x)
    
38.                           )
    
39.                         )
    
40.                        pDesigns
    
41.                      ) ;_设计线对应点处切线方向
    
42.             pDists   (mapcar '(lambda (x y z)
    
43.                                 (xdrx_point_dist2line x y z)
    
44.                               )
    
45.                              pActuals
    
46.                              pDesigns
    
47.                              pVectors
    
48.                      ) ;_距离正负表示在设计线内外
    
49.       )
    
50.       ;;mapcar 处理
    
51.       (setq h        (getvar "textsize")
    
52.             sty        (getvar "textstyle")
    
53.       )
    
54.       (setvar "dimzin" 0)
    
55.       (mapcar '(lambda (x y z / str zl p txt an d)
    
56.                  (if (not (equal z 0.0 1e-3))
    
57.                    (progn
    
58.                      (xdrx_circle_make x 0.1)
    
59.                      (if (minusp z)
    
60.                        (setq str (rtos z 2 3))
    
61.                        (setq str (strcat "+" (rtos z 2 3)))
    
62.                      )
    
63.                      (setq zl (XD::String:ActualWidth str sty h 1.0)
    
64.                            d  (1+ (* 0.5 zl))
    
65.                      )
    
66.                      (if (minusp z)
    
67.                        (setq an        (angle x y)
    
68.                              p        (polar y an d)
    
69.                        )
    
70.                        (setq an        (angle y x)
    
71.                              p        (polar x an d)
    
72.                        )
    
73.                      )
    
74.                      (setq
    
75.                        txt (xdrx_text_make
    
76.                              p
    
77.                              str
    
78.                              h
    
79.                              (XD::Geom:AngleFormat an)
    
80.                            )
    
81.                      )
    
82.                      (xdrx_text_sethozmode txt 1)
    
83.                      (xdrx_text_setvermode txt 2)
    
84.                      (xdrx_text_setalignmentpoint txt p)
    
85.                    )
    
86.                  )
    
87.                )
    
88.               pActuals
    
89.               pDesigns
    
90.               pDists
    
91.       )
    
92.     )
    
93.   )
    
94.   (princ)
    
95. )

(defun c:cqw (/ filter ss e1 e2 pActuals pDesigns pVertors pDists h sty)<br />   (setq        filter '((0 . "LWPOLYLINE")<br />                  (-4 . "&=")<br />                  (70 . 0)<br />                 )<br />   )<br />   (if (and (setq e1 (car (xdrx_entsel<br />                            "\n选择实际开挖线: "<br />                            (cons '(8 . "实际开挖线") filter)<br />                          )<br />                     )<br />            )<br />            (setq e2 (car (xdrx_entsel<br />                            "\n选择设计开挖线: "<br />                            (cons '(8 . "设计开挖线") filter)<br />                          )<br />                     )<br />            )<br />            (progn<br />              (if (not (xdrx_curve_direction e2)) ;_判断逆时针<br />                (xdrx_curve_reverse e2)<br />              )<br />              t<br />            )<br />       )<br />     (progn<br />       (setq pActuals (xdrx_getpropertyvalue e1 "Vertices") ;_实际开挖点<br />             pDesigns (mapcar '(lambda (x)<br />                                 (xdrx_curve_getclosestpoint e2 x)<br />                               )<br />                              pActuals<br />                      ) ;_对应设计点<br />             pVectors (mapcar<br />                        '(lambda        (x)<br />                           (mapcar '+<br />                                   x<br />                                   (xdrx_curve_getfirstderiv e2 x)<br />                           )<br />                         )<br />                        pDesigns<br />                      ) ;_设计线对应点处切线方向<br />             pDists   (mapcar '(lambda (x y z)<br />                                 (xdrx_point_dist2line x y z)<br />                               )<br />                              pActuals<br />                              pDesigns<br />                              pVectors<br />                      ) ;_距离正负表示在设计线内外<br />       )<br />       ;;mapcar 处理<br />       (setq h        (getvar "textsize")<br />             sty        (getvar "textstyle")<br />       )<br />       (setvar "dimzin" 0)<br />       (mapcar '(lambda (x y z / str zl p txt an d)<br />                  (if (not (equal z 0.0 1e-3))<br />                    (progn<br />                      (xdrx_circle_make x 0.1)<br />                      (if (minusp z)<br />                        (setq str (rtos z 2 3))<br />                        (setq str (strcat "+" (rtos z 2 3)))<br />                      )<br />                      (setq zl (XD::String:ActualWidth str sty h 1.0)<br />                            d  (1+ (* 0.5 zl))<br />                      )<br />                      (if (minusp z)<br />                        (setq an        (angle x y)<br />                              p        (polar y an d)<br />                        )<br />                        (setq an        (angle y x)<br />                              p        (polar x an d)<br />                        )<br />                      )<br />                      (setq<br />                        txt (xdrx_text_make<br />                              p<br />                              str<br />                              h<br />                              (XD::Geom:AngleFormat an)<br />                            )<br />                      )<br />                      (xdrx_text_sethozmode txt 1)<br />                      (xdrx_text_setvermode txt 2)<br />                      (xdrx_text_setalignmentpoint txt p)<br />                    )<br />                  )<br />                )<br />               pActuals<br />               pDesigns<br />               pDists<br />       )<br />     )<br />   )<br />   (princ)<br /> )

lizhgang.jin

st788796 发表于 2015-1-7 10:24
需要 XDAPI + xd-lisp-lib.vlx

谢谢，能告诉我怎么用吗，还是加载那个晓东插件然后加载这个LSP 就可以了吗。

skg123

dwp@hamco 发表于 2014-12-29 12:28

下载试用了一下，2004CAD上不能运行。

skg123

skg123 发表于 2015-10-25 18:05
下载试用了一下，2004CAD上不能运行。

运行出现 错误：  请输入实际开挖线上标注间隔数(默认为0):2 ; 错误: 参数太多


修改后代码

2. ;文件名：ddd.lsp
   
3. ;;功能说明：标注实际开挖线各点与设计开挖线之间的距离
   
4. ;;;修改时间：2015-01-07  ss en v-en pc ss1 en1 po-li n p11 pt pt@curve osm
   
5. 
   
6. (vl-load-com)
   
7. (defun c:ddd(/ )  
   
8.   (setq osm (getvar "osmode"))  
   
9.   (setvar "cmdecho" 0)
   
10.   (setvar "osmode" 0)  
    
11. 
    
12.   (while
    
13.     (progn
    
14.       (prompt "\n请选择设计开挖线：")
    
15.       (not(setq ss(ssget ":s" '((0 . "CIRCLE,*POLYLINE")))))
    
16.         );end progn
    
17.     (prompt "\n<<<<未选择到正确的对象，请重新选择!>>>>")
    
18.   );end while
    
19. 
    
20.   (setq en(ssname ss 0)
    
21.         v-en(vlax-ename->vla-object en)
    
22.     )  
    
23.   (setq pc(find-centerpoint en));找设计开挖线的型心
    
24. 
    
25.   (while(progn(prompt "\n请选择实际开挖线：")
    
26.                 (not(setq ss1(ssget ":s" '((0 . "*POLYLINE")))))
    
27.         );end progn
    
28.     (prompt "\n<<<<未选择到正确的对象，请重新选择!>>>>")
    
29.   );end while
    
30. 
    
31.   (setq en1(ssname ss1 0))
    
32.   (setq po-li (vl-remove-if 'not (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) (entget en1))));取多段线顶点表
    
33. 
    
34.   (initget 6)
    
35.   (setq n (getint "\n 请输入实际开挖线上标注间隔数(默认为0):"))
    
36.   (if(null n)(setq n 0))
    
37. 
    
38.   (if(/= n 0)(setq po-li(get-new-point-list po-li n)));end if
    
39. 
    
40.   (foreach pt po-li   
    
41.     (setq pt@curve(vlax-curve-getClosestPointTo v-en pt))
    
42.    
    
43.     (if(> (distance pt pc) (distance pt@curve pc));如果超挖
    
44.       (progn
    
45.       (setq p11 (polar pt@curve (angle pt@curve pt) (* 2 (distance pt pt@curve))))
    
46.       ;(make-dimension pt pt@curve p11 "隧道超挖+")
    
47.       (make-dimension pt pt@curve p11)
    
48.     ;   (command "_.pline" P11 pc "")
    
49.       );end progn
    
50.       );end if
    
51. 
    
52.     (if(< (distance pt pc) (distance pt@curve pc));如果欠挖
    
53.       (progn
    
54.       (setq p11(polar pt(angle pt pt@curve ) (* 3 (distance pt pt@curve))))
    
55. ;(make-dimension pt@curve pt p11 "隧道欠挖-")
    
56. (make-dimension pt@curve pt p11)
    
57.      ;  (command "_.pline" Pt p11 "")
    
58.       );end progn
    
59.       );end if
    
60.       
    
61.     );end foreach
    
62.   
    
63.   (setvar "osmode" osm)
    
64.   (princ)  
    
65.   );end defun
    
66. 
    
67. ;;;sub-routine1
    
68. (defun find-centerpoint(en / po-li n y pc)
    
69.   (setq entda(entget en)
    
70.         ename(cdr(assoc 0 entda)))
    
71.   (if(= ename "CIRCLE")
    
72.     (setq pc(cdr(assoc 10 entda)))
    
73.     (progn
    
74.       (setq po-li (vl-remove-if 'not (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) entda)))
    
75.       (setq n(length po-li))  
    
76.       (setq y(apply 'mapcar (cons '+ po-li)))
    
77.       (setq pc(mapcar '/ y (list n n n)))
    
78.       );progn
    
79.     );end if
    
80.   );end defun
    
81. 
    
82. ;;;sub-routine2
    
83. (defun make-dimension (p13 p14 p11 dimsty)
    
84.   (entmake (list '(0 . "DIMENSION")
    
85.                  '(100 . "AcDbEntity")
    
86.                  '(100 . "AcDbDimension")                 
    
87.                   (cons 10 p14)
    
88.                   (cons 11 p11)
    
89.                  '(70 . 33)
    
90.                  '(1 . "")
    
91.                   (cons 3 dimsty)
    
92.                  '(100 . "AcDbAlignedDimension")
    
93.                  (cons 13 p13)
    
94.                  (cons 14 p14)
    
95.                  )
    
96.            );endmake  
    
97.   );end defun
    
98. 
    
99. ;;;sub-routine3
    
100. ;;;间隔N个数取点表
     
101. (defun get-new-point-list(li n / s-li i k)
     
102.   (setq s-li nil i 0 k (1+ n))
     
103. 
     
104.   (while(nth i li)
     
105.     (setq s-li(cons (nth i li) s-li))
     
106.     (setq i(+ i k))
     
107.     );end while
     
108.   
     
109.   (reverse s-li)
     
110.   );end defun
     

;文件名：ddd.lsp<br /> ;;功能说明：标注实际开挖线各点与设计开挖线之间的距离<br /> ;;;修改时间：2015-01-07  ss en v-en pc ss1 en1 po-li n p11 pt pt@curve osm<br /> <br /> (vl-load-com)<br /> (defun c:ddd(/ )  <br />   (setq osm (getvar "osmode"))  <br />   (setvar "cmdecho" 0)<br />   (setvar "osmode" 0)  <br /> <br />   (while<br />     (progn<br />       (prompt "\n请选择设计开挖线：")<br />       (not(setq ss(ssget ":s" '((0 . "CIRCLE,*POLYLINE")))))<br />         );end progn<br />     (prompt "\n<<<<未选择到正确的对象，请重新选择!>>>>")<br />   );end while<br /> <br />   (setq en(ssname ss 0)<br />         v-en(vlax-ename->vla-object en)<br />     )  <br />   (setq pc(find-centerpoint en));找设计开挖线的型心<br /> <br />   (while(progn(prompt "\n请选择实际开挖线：")<br />                 (not(setq ss1(ssget ":s" '((0 . "*POLYLINE")))))<br />         );end progn<br />     (prompt "\n<<<<未选择到正确的对象，请重新选择!>>>>")<br />   );end while<br /> <br />   (setq en1(ssname ss1 0))<br />   (setq po-li (vl-remove-if 'not (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) (entget en1))));取多段线顶点表<br /> <br />   (initget 6)<br />   (setq n (getint "\n 请输入实际开挖线上标注间隔数(默认为0):"))<br />   (if(null n)(setq n 0))<br /> <br />   (if(/= n 0)(setq po-li(get-new-point-list po-li n)));end if<br /> <br />   (foreach pt po-li    <br />     (setq pt@curve(vlax-curve-getClosestPointTo v-en pt))<br />     <br />     (if(> (distance pt pc) (distance pt@curve pc));如果超挖<br />       (progn<br />       (setq p11 (polar pt@curve (angle pt@curve pt) (* 2 (distance pt pt@curve))))<br />       ;(make-dimension pt pt@curve p11 "隧道超挖+")<br />       (make-dimension pt pt@curve p11)<br />     ;   (command "_.pline" P11 pc "")<br />       );end progn<br />       );end if<br /> <br />     (if(< (distance pt pc) (distance pt@curve pc));如果欠挖<br />       (progn<br />       (setq p11(polar pt(angle pt pt@curve ) (* 3 (distance pt pt@curve))))<br /> ;(make-dimension pt@curve pt p11 "隧道欠挖-")<br /> (make-dimension pt@curve pt p11)<br />      ;  (command "_.pline" Pt p11 "")<br />       );end progn<br />       );end if<br />        <br />     );end foreach<br />   <br />   (setvar "osmode" osm) <br />   (princ)  <br />   );end defun<br /> <br /> ;;;sub-routine1<br /> (defun find-centerpoint(en / po-li n y pc)<br />   (setq entda(entget en)<br />         ename(cdr(assoc 0 entda)))<br />   (if(= ename "CIRCLE")<br />     (setq pc(cdr(assoc 10 entda)))<br />     (progn<br />       (setq po-li (vl-remove-if 'not (mapcar '(lambda (x) (if (= (car x) 10) (cdr x))) entda)))<br />       (setq n(length po-li))  <br />       (setq y(apply 'mapcar (cons '+ po-li)))<br />       (setq pc(mapcar '/ y (list n n n)))<br />       );progn<br />     );end if<br />   );end defun<br /> <br /> ;;;sub-routine2<br /> (defun make-dimension (p13 p14 p11 dimsty)<br />   (entmake (list '(0 . "DIMENSION")<br />                  '(100 . "AcDbEntity")<br />                  '(100 . "AcDbDimension")                 <br />                   (cons 10 p14)<br />                   (cons 11 p11)<br />                  '(70 . 33)<br />                  '(1 . "")<br />                   (cons 3 dimsty)<br />                  '(100 . "AcDbAlignedDimension")<br />                  (cons 13 p13)<br />                  (cons 14 p14)<br />                  )<br />            );endmake  <br />   );end defun<br /> <br /> ;;;sub-routine3<br /> ;;;间隔N个数取点表<br /> (defun get-new-point-list(li n / s-li i k)<br />   (setq s-li nil i 0 k (1+ n))<br /> <br />   (while(nth i li)<br />     (setq s-li(cons (nth i li) s-li))<br />     (setq i(+ i k))<br />     );end while<br />   <br />   (reverse s-li)<br />   );end defun<br />

wklCAD

dwp@hamco 发表于 2015-1-6 17:14

大师，我用您这个代码运行，在输入间隔点参数之后，没有任何反应是为什么？       ps：本人用的CAD2008

wklCAD

lizhgang.jin 发表于 2015-1-7 10:09

楼主你好，可否把你那个批量标注超欠挖的lsp共享下，我用帖子里的代码，在输入间隔点参数后没反应。

w18089326749

st788796 发表于 2015-1-7 08:57
上面程序没有写标注部分，不是完整应用，另外需要加载 XDRXAPI

怎么标注出来超欠负号没有
来自: 微社区

w18089326749

lizhgang.jin 发表于 2015-1-7 10:04
老师您的程序试用了，很好很方便。如果你有空的话还可以有个小改动，就是我标完一个图后，下一个图标的时 ...

怎么做的，发个给我
来自: 微社区

Roue-十一啊

这个帖子还有人嘛，加载之后是这个问题
错误: 读入的 (八进制) 字符不正确: 0
应该怎么解决啊

Roue-十一啊

这个帖子还有人嘛，加载之后是这个问题
错误: 读入的 (八进制) 字符不正确: 0
应该怎么解决啊

MUYIY

牛，解决问题了，

60ck

st788796 发表于 2015-1-7 10:24
需要 XDAPI + xd-lisp-lib.vlx

点击实际开挖线，出现错误的消息
*** No eligible entities were picked up, try again!

60ck

lizhgang.jin 发表于 2015-1-7 10:09
问题已解决

您好
请问一下，可以分享已解决的插件吗？