可编辑文档
1.计算所有线段总长度(加载后只需框选所有线段便可得出这些线段的总长度)
(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))
1/18
可编辑文档
)
(princ \"所选线条总长为：\")(princ ll)(princ)
)
2.标注所有线段(加载后只需框选所有线段便可得标注这些线段)
(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)
)
;;选取需要测量的样条曲线、圆弧、直线、椭圆
2/18
可编辑文档
(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))
3/18
可编辑文档
(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
4/18
可编辑文档
(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))
5/18
可编辑文档
(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))
6/18
可编辑文档
)
(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))
7/18
可编辑文档
)
)
(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))
)
8/18
可编辑文档
(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))
9/18
可编辑文档
(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
10/18
可编辑文档
\"\"
(* (/ ang pi) 180)
(strcat \"\" (rtos dd 2))
\"\"
)
(setq i (1+ i))
)
(prin1)
)
(prompt \"\\n <>在图中直接写出长度\")
(prin1)
3.连续打断程序
(defun c:br1 ()
11/18
可编辑文档
(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)))
12/18
可编辑文档
(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)
)
13/18
可编辑文档
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 命令就可以将图元改为红色了.其余类似.
删除红色图元
14/18
可编辑文档
(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) )
15/18
可编辑文档
这样,键入 D1 命令,就可以删除红色的图元了.
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
16/18
可编辑文档
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
17/18
可编辑文档
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
(精选文档，可编辑word，整理文档不易，建议收藏)
18/18