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

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

本帖最后由 lizhgang.jin 于 2015-1-7 10:21 编辑

问题已解决

st788796 · 发表于 2015-1-7 10:24:57

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

需要 XDAPI + xd-lisp-lib.vlx

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

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

lizhgang.jin · 发表于 2015-1-7 11:23:40

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

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

skg123 · 发表于 2015-10-25 18:05:25

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

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

skg123 · 发表于 2015-10-27 15:58:41

本帖最后由 skg123 于 2015-10-27 18:30 编辑

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

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

修改后代码

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

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

wklCAD · 发表于 2018-2-8 11:33:26

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

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

wklCAD · 发表于 2018-2-8 11:35:24

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

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

w18089326749 · 发表于 2018-11-19 18:40:17

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

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

w18089326749 · 发表于 2018-11-19 18:58:55

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

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

Roue-十一啊 · 发表于 2020-9-13 16:20:30

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

Roue-十一啊 · 发表于 2020-9-13 16:21:44

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

MUYIY · 发表于 2022-6-11 14:26:13

牛，解决问题了，

账号		自动登录	找回密码
密码			立即注册

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

点评

点评