CAD统计多条线段长度程序及程序加载方法

用下面的这个程序可以，加载后执行命令：mulen(defun c:mulen() (setq i 1 s 0) (prompt 选择直线：) (setq ss (ssget) (setq leng (sslength ss) (setq namelist (list(ssname ss 0) (repeat (1- leng) (setq namelist (append namelist (list (ssname ss i) (setq i (1+ i) (foreach name namelist (setq nameall (entget name) (setq ps (cdr (assoc 10 nameall) (setq pe (cdr (assoc 11 nameall) (setq psx (car ps) (setq psy (cadr ps) (setq psz (caddr ps) (setq pex (car pe) (setq pey (cadr pe) (setq pez (caddr pe) (setq x (- psx pex) (setq y (- psy pey) (setq z (- psz pez) (setq length (sqrt (+ (expt x 2) (expt y 2) (expt z 2) (setq s (+ s length) ) (princ (strcat 直线总长为：(rtos s) (princ):em27上述为程序内容，然后存为：“文件名.lsp”，再从CAD里用appload命令加载此文件。这里有一个程序，你可以用用看，命令为AM对line ,arc ,ellispe,spline,polyline,lwpolyline,circle,mline,solid均有效。你既可统计长度，也可统计面积，或者两者都统计。如果你对精确位不满意，你可以改动程序中的数字（我已经在程序注释中说明）。;= ;面积和长度统计程序 ;highflybird kunming ;= (prompt 命令为:AM) (defun C:am (/ fssliSSareatotlenentlen enamenameobjtext-Stext-LinsPt0height insPt1insPt2text-1text-2*APP*DOC*MSP ) (vl-load-com) (setq *APP (vlax-get-acad-object) (setq *DOC (vla-get-activeDocument *APP) (setq *MSP (vla-get-Modelspace *DOC) (initget 1 1 2 3) (setq f (getkword n请输入你要统计的面积长度两者:) (if (and (setq ss (ssget) (setq insPt0 (getpoint n请输入文字插入点: ) (setq height (getdist n请输入文字高度:) ) (progn (setq l (sslength ss) (setq i 0) (setq SSarea 0) (setq totlen 0) (setq insPt1 (vlax-3d-point insPt0) (setq insPt2 (polar insPt0 (* 1.5 Pi) (* 1.5 height) (setq insPt2 (vlax-3d-point insPt2) (cond ( (= f 1) (repeat l (func-1) (func-2) (setq i (1+ i) ) (setq text-S (strcat (convert1 SSarea 6) 平方米);总面积为:小数后6位 (vla-addtext *MSP text-S insPt1 height) ) ( (= f 2) (repeat l (func-1) (func-3) (setq i (1+ i) ) (setq text-L (strcat (convert1 totlen 4) 米);总长度为:小数后4位 (vla-addtext *MSP text-L insPt2 height) ) ( (= f 3) (repeat l (func-1) (func-2) (func-3) (setq i (1+ i) ) (setq text-S (strcat (convert1 SSarea 6) 平方米);总面积为:小数后6位 (setq text-L (strcat (convert1 totlen 3) 米);总长度为:小数后3位 (vla-addtext *MSP text-S insPt1 height) (vla-addtext *MSP text-L insPt2 height) ) ) ) (alert 你没有选取物体或者输入正确的数据!) ) (princ) ) (defun func-1 () (setq ename (ssname ss i) (setq obj (vlax-ename-vla-object ename) (setq elist (entget ename) (setq name (cdr (assoc 0 elist) ) ;面积的统计 (defun func-2 (/ p1 p2 p3 p4) (if (vlax-property-available-p obj area) (setq SSarea (+ (vla-get-area obj) SSarea) (if(= name SOLID) (setq p1 (cdr (assoc 10 elist) p2 (cdr (assoc 11 elist) p3 (cdr (assoc 12 elist) p4 (cdr (assoc 13 elist) SSarea (+ (area-of-verties (list p1 p2 p4 p3) SSarea) ) ) ) ) ;长度的统计 (defun func-3 (/ p1 p2 p3 p4) (cond ( (= name MLINE) (setq totlen (+ totlen (ml-length ename) ) ( (or (= name ARC) (= name CIRCLE) (= name LINE) (= name POLYLINE) (= name LWPOLYLINE) (= name SPLINE) (= name ELLIPSE) ) (setq entlen (vlax-curve-getdistatparam ename (vlax-curve-getendparam ename) (setq totlen (+ totlen entlen) ) ( (= name SOLID) (setq p1 (cdr (assoc 10 elist) (setq p2 (cdr (assoc 11 elist) (setq p3 (cdr (assoc 12 elist) (setq p4 (cdr (assoc 13 elist) (setq totlen (+ (length-of-verties (list p1 p2 p4 p3) totlen) ) ) ) ;Mline的长度 (defun ml-length (ename / j d ptlist) (foreach n (entget ename) (if(= (car n) 11) (setq ptlist (cons (cdr n) ptlist) ) ) (reverse ptlist) (setqj 0) (setq d 0) (repeat (1- (length ptlist) (setq d (+ d (distance (nth j ptlist) (nth (1+ j) ptlist) (setq j (1+ j) ) d ) ;单位转化 (defun convert (x n / tol_x fra_x int_x) (setq tol_x (/ x (expt 10 n) (setq fra_x (rtos (- tol_x (fix tol_x) 2 n) (setq fra_x (vl-string-left-trim 0 fra_x) (setq int_x (itoa (fix tol_x) (strcat int_x fra_x) ) (defun convert1 (x n / tol_x fra_x int_x) (setq tol_x (/ x (expt 10 n) (setq fra_x (rtos (- tol_x (fix tol_x) 2 3) (setq fra_x (vl-string-left-trim 0 fra_x) (setq int_x (itoa (fix tol_x) (strcat int_x fra_x) ) ;n个点的长度 (defun length-of-verties (pts / i l len pts1) (setq i -1 len 0) (setq pts1 (cons (last pts) pts) (repeat (length pts) (setq i(1+ i) (setq l(distance (nth i pts1) (nth (1+ i) pts1) (setq len (+ l len) ) ) ;n个点的面积 (defun area-of-verties (pts / i area PX0 PY0 x1 y1 x2 y2) (setq i 0) (setq area 0) (setq px0 (caar pts) (setq py0 (cadar pts) (repeat (- (len