哪位程序编写大师帮我修改CAD标注隧道的超欠挖插件,保证能运行!

查看 64|回复 9
作者:tzhdchina   
购买了一个CAD标注隧道的超欠挖的插件,发现运行补不了,麻烦哪位高手帮我修改能运行,跟我图片的一样标注最好了!感谢吾爱破解的大神!发我邮箱[email protected]
;文件名:PB.lsp
;;功能说明:标注实际开挖线各点与设计开挖线之间的距离
;;;修改时间:2015-01-07  ss en v-en pc ss1 en1 po-li n p11 pt pt@curve osm
(vl-load-com)
(defun c:PB(/ )  
  (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 "+" 3);箭头及线颜色3 绿色
    ;   (command "_.pline" P11 pc "")
      );end progn
      );end if
    (if(" 1);箭头及线颜色1 红色
     ;  (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 (p14 p13 p11 dimsty ys)
  (entmake (list '(0 . "DIMENSION")
                 '(100 . "AcDbEntity")
                 '(100 . "AcDbDimension")                 
                  (cons 10 p14)
                  (cons 11 p11)
                 '(70 . 33)
                  (cons 1 dimsty);前缀符号
                  (cons 3 "超欠挖")
                 '(100 . "AcDbAlignedDimension")
                 (cons 13 p13)
                 (cons 14 p14)
                 (cons 62 ys) ;箭头及线颜色
                 )
           );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

隧道, 帮我

tzhdchina
OP
  

file:///C:/Users/32822/Desktop/%E6%8F%92%E4%BB%B6%E5%9B%BE%E7%89%87.png
tzhdchina
OP
  

怎么发不了图片上去?
tzhdchina
OP
  

file:///C:/Users/32822/Desktop/%E6%8F%92%E4%BB%B6%E5%9B%BE%E7%89%87.png
cayuer   


tzhdchina 发表于 2025-6-3 14:42
怎么发不了图片上去?

图片要用图床 直接上传不可以的
cioceo   

传一个cad文件上来调试
tzhdchina
OP
  


cioceo 发表于 2025-6-3 16:25
传一个cad文件上来调试

怎么上传
cioceo   


tzhdchina 发表于 2025-6-3 16:38
怎么上传

网盘分享链接
tzhdchina
OP
  


cioceo 发表于 2025-6-3 16:40
网盘分享链接

通过网盘分享的文件:CAD图形
链接: https://pan.baidu.com/s/1vr_f9Xg28B3IpVsVusC3NA?pwd=f5dw 提取码: f5dw
tzhdchina
OP
  


cioceo 发表于 2025-6-3 16:40
网盘分享链接

能改成和我发的CAD图形一样的标注最好了
您需要登录后才可以回帖 登录 | 立即注册

返回顶部