幾個很有用的CAD的lisp程序，給大家分享一下
工具/原料
《AutoCAD視頻教程全集》地址在參考資料裡哦
計算所有線段總長度(加載後只需框選所有線
(defun c:LL ()(setvar "cmdecho" 1)(setq en (ssget (list '(0 . "spline,arc,line,ellipse,LWPOLYLINE"))))(setq i 0)(setq ll 0)(repeat (sslength en) (setq ss (ssname en i)) (setq endata (entget ss)) (command "lengthen" ss "") (setq dd (getvar "perimeter"))(setq ll (+ dd ll)) (setq i (1+ i))) (princ "所選線條總長為：")(princ ll)(princ))
標註所有線段(加載後只需框選所有線段便可
(defun c:LLL ()(COMMAND "UCS" "")(setvar "cmdecho" 1)(SETVAR "OSMODE" 0)(setq AcadObject (vlax-get-acad-object) AcadDocument (vla-get-ActiveDocument Acadobject) mSpace (vla-get-ModelSpace Acaddocument));;選取需要測量的樣條曲線、圓弧、直線、橢圓(setq en (ssget (list '(0 . "spline,arc,line,ellipse,LWPOLYLINE"))))(setq i 0);;獲取系統參數textsize(setq shh (getvar "textsize"))(setq str_hh (strcat "\n文字高度 <" (rtos shh 2) ">: "))(setq hh (getdist str_hh))(while hh(setvar "textsize" hh)(setq hh nil));;輸入標註文字高度;;循環開始(repeat (sslength en) (setq ss (ssname en i)) (setq endata (entget ss)) (command "lengthen" ss "") (setq dd (getvar "perimeter")) (princ (strcat "\n長度=" (rtos dd 2))) ;;尋找代表圖層的字符串 (setq aa (assoc 0 endata)) ;;獲取圖層名稱 (setq aa1 (cdr aa)) ;;判斷線條種類 (cond ((= aa1 "SPLINE") ;;如果是spline (progn (setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) (setq startPnt1 (vla-get-ControlPoints arcObj)) (setq p1 (vlax-safearray->list (vlax-variant-value startPnt1)) ) (setq x1 (car p1)) (setq y1 (cadr p1)) (setq z1 (caddr p1)) (setq pp1 (list x1 y1 z1)) (repeat (- (/ (length p1) 3) 1) ;;循環，尋找最後一個控制點 (setq p1 (cdddr p1)) (setq x2 (car p1)) (setq y2 (cadr p1)) (setq z2 (caddr p1)) ) (setq pp2 (list x2 y2 z2)) ) ) ((= aa1 "LWPOLYLINE") ;;如果是LWPOLYLINE (progn (setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) (setq startPnt1 (vla-get-Coordinates arcObj)) (setq p1 (vlax-safearray->list (vlax-variant-value startPnt1)) ) (setq x1 (car p1)) (setq y1 (cadr p1)) (setq z1 (caddr p1)) (setq pp1 (list x1 y1 z1)) (repeat (- (/ (length p1) 3) 1) ;;循環，尋找最後一個控制點 (setq p1 (cdddr p1)) (setq x2 (car p1)) (setq y2 (cadr p1)) (setq z2 (caddr p1)) ) (setq pp2 (list x2 y2 z2)) ) ) (t ;;如果是其他種類線條 (progn (setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) (setq startPnt1 (vla-get-StartPoint arcObj)) ;;獲取起點 (setq endPnt1 (vla-get-EndPoint arcObj)) ;;獲取終點 (setq pp1 (vlax-safearray->list (vlax-variant-value startPnt1)) ) (setq pp2 (vlax-safearray->list (vlax-variant-value endPnt1)) ) ) ) ) (setq x1 (car pp1)) (setq y1 (cadr pp1)) (setq z1 (caddr pp1)) (setq x2 (car pp2)) (setq y2 (cadr pp2)) (setq z2 (caddr pp2)) (setq x (/ (+ x1 x2) 2)) (setq y (/ (+ y1 y2) 2)) (setq z (/ (+ z1 z2) 2)) (setq pt (list x y z)) ;;取得線段兩端的中點 (setq ang (angle pp1 pp2)) ;;獲取角度 (if (> (* (/ ang pi) 180) 180) (setq ang (+ ang pi)) ) (command "text" "j" "bc" pt "" (* (/ ang pi) 180) (strcat "" (rtos dd 2)) "" ) (setq i (1+ i)))(prin1))(prompt "\n <>在圖中直接寫出長度")(prin1)
連續打斷程序
(defun c:br1 () (command "break" pause "f" pause "@"))
將CAD文字導入Excel表格
(defun c:Q2()(setq ffn (getfiled "寫出文件" "" "xls" 1))(princ "\n選取文字...")(setq ss (ssget))(setq ff (open ffn "w"))(setq i 0)(repeat (sslength ss)(setq ssn (ssname ss i))(setq ssdata (entget ssn))(setq sstyp (cdr (assoc 0 ssdata)))(if (or (= sstyp "TEXT") (= sstyp "MTEXT"))(progn(setq txt (cdr (assoc 1 ssdata)))(princ txt ff)(princ "\n" ff)))(setq i (1+ i)) )(close ff)(princ (strcat "\n寫出文件: " ffn))(prin1))
刪除帶顏色圖元
改顏色的LISP程序(defun c:c1()(ssget)(command "chprop" "p" "" "c" "1" "") (princ))(defun c:c2()(ssget)(command "chprop" "p" "" "c" "2" "") (princ))(defun c:c3()(ssget)(command "chprop" "p" "" "c" "3" "") (princ))(defun c:c4()(ssget)(command "chprop" "p" "" "c" "4" "") (princ))(defun c:c5()(ssget)(command "chprop" "p" "" "c" "5" "") (princ))(defun c:c6()(ssget)(command "chprop" "p" "" "c" "6" "") (princ))(defun c:c7()(ssget)(command "chprop" "p" "" "c" "7" "") (princ))(defun c:c8()(ssget)(command "chprop" "p" "" "c" "8" "") (princ))你用C1 命令就可以將圖元改為紅色了.其餘類似.刪除紅色圖元(defun C:D1 (/ m A M) (setq m:err *error* *error* *merr*) (setvar "cmdecho" 0) (command "UNDO" "G") (prompt "選擇圖形") (setq A (ssget '((62 . 1)) )) (if (/= A nil)(progn (setq M (sslength A)) (command "erase" A "") (princ "\n共刪除紅色圖元<")(princ M)(princ ">個") )) (command "UNDO" "E") (princ) ) 這樣,鍵入 D1 命令,就可以刪除紅色的圖元了。更多cad技巧、知識在經驗下方的《AutoCAD視頻教程全集》裡。
注意事項
參考資料裡的是官方唯一發布的