我的CAD是2004版的，谁能不能给个2008版的指令LISP,我想加载进去，不想改版本
发布网友
发布时间：2022-05-02 01:09
共1个回答
热心网友
时间：2023-10-08 23:08
(if (null vlax-mp-object) (vl-load-com) )
(if (null &mod) (setq &mod (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))) )
(if (setq &len (entsel "\n选择要测量斜度的线段 "))
(progn
(setq @pts (cadr &len) &len (vlax-ename->vla-object (car &len)))
(setq @pto (vlax-curve-getclosestpointto &len @pts))
(setq @pt1 (vlax-curve-getclosestpointto &len (polar @pts (* pi 0.5) 0.001)))
(setq @pt2 (vlax-curve-getclosestpointto &len (polar @pts (* pi 1.5) 0.001)))
(setq #ang (min (angle @pt1 @pt2) (angle @pt2 @pt1)))
(setq #j T &mte nil &lea nil)
(while #j
(setq @jj (grread 1 4 1) #j (car @jj) @j (cadr @jj))
(cond
((= #j 5) ($dq-moveaction) )
((= #j 3) ($dq-clickleft) )
((= #j 12) ($dq-clickright) )
)
)
)
)
(princ)
)
(defun $dq-clickleft ( )
(setq #j nil) (princ " OK!")
)
(defun $dq-clickright ( )
(if (and &mte (null (vlax-erased-p &mte)))
(vla-erase &mte)
)
(if (and &lea (null (vlax-erased-p &lea)))
(vla-erase &lea)
)
(setq #j nil) (princ " Cancel!")
)
(defun $dq-leaderpoint ( pts / lis dou )
(setq lis (apply 'append (mapcar '(lambda (x) (list (car x) (cadr x) (caddr x))) pts)))
(setq dou (vlax-make-safearray vlax-vbdouble (cons 0 (1- (* 3 (length pts))))))
(vlax-make-variant (vlax-safearray-fill dou lis))
)
(defun $dq-moveaction ( )
(if (> (setq #ang (/ (* #ang 180) pi)) 90)
(setq #ang (- 180 #ang))
)
(if (or (null &mte) (vlax-erased-p &mte))
(progn
(setq &mte (vla-addmtext &mod (vlax-3d-point @j) 0 (strcat (rtos #ang 2 (getvar "DIMDEC")) "%%D")))
(vla-put-color &mte (getvar "DIMCLRT"))
(vla-put-stylename &mte (getvar "DIMTXSTY"))
(vla-put-height &mte (getvar "DIMTXT"))
)
(vla-put-insertionpoint &mte (vlax-3d-point @j))
)
(if (> (car @j) (car @pto))
(if (< (cadr @j) (cadr @pto))
(if (> (angle @pto @j) (angle @j @pto))
(vla-put-attachmentpoint &mte 4)
(vla-put-attachmentpoint &mte 6)
)
(if (< (angle @pto @j) (angle @j @pto))
(vla-put-attachmentpoint &mte 4)
(vla-put-attachmentpoint &mte 6)
)
)
(if (> (cadr @j) (cadr @pto))
(if (> (angle @pto @j) (angle @j @pto))
(vla-put-attachmentpoint &mte 4)
(vla-put-attachmentpoint &mte 6)
)
(if (< (angle @pto @j) (angle @j @pto))
(vla-put-attachmentpoint &mte 4)
(vla-put-attachmentpoint &mte 6)
)
)
)
(if (or (null &lea) (vlax-erased-p &lea))
(setq &lea (vla-addleader &mod ($dq-leaderpoint (list @pto @j)) &mte aclinewitharrow))
(vla-put-Coordinates &lea ($dq-leaderpoint (list @pto @j)))
)
(vla-put-verticaltextposition &lea 0)
(vla-update &lea)
)
;;;帮人写的选定斜线用引线加文字来标注角度的程序，不短了吧
追问我要的是那些加载指令的哦，比如说螺旋，总之04版没有的。
