几个很有用的CAD的lisp程序

来源:真空技术网(www.chvacuum.com)真空技术网整理 作者:CAD小苗

1、计算CAD图形中所有线段总长度(加载后只需框选所有线段便可得出这些线段的总长度)

  (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)

  )

2、标注CAD图形中所有线段(加载后只需框选所有线段便可得标注这些线段)

  (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)

3、连续打断程序

  (defun c:br1 ()

  (command "break" pause "f" pause "@")

  )

4、将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)

  )

5、删除带颜色图元

  以下程序在别人的贴子里贴过.为了说明问题,今天再贴一次。

  改颜色的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的lisp程序为真空技术网首发,转载请以链接形式标明本文首发网址。

  http://www.chvacuum.com/autocad/114583.html

  与 AutoCAD教程 lisp程序 相关的文章请阅读:

  AutoCAD教程http://www.chvacuum.com/autocad/