用lisp写的计算线长的程式

zylaser

明经通道的计算线长程式一次只能选一条线，极不方便，这是我用lisp写的计算线长的程式，非常好用

(defun c:abk ()
(setvar "cmdecho" 0)
(command "layer" "S" "0" "")
(setq p  (/ pi 2.0)
      g (+ pi p))
   (setq aa (ssget))
  (setq i 0)
   (setq ab (ssadd))
   (repeat (sslength aa)
    (setq aab (ssname aa i))
     (setq bb (cdr (assoc 0 (entget aab))))
     (cond ((= bb "LINE")
           (setq pd (list aab (cdr (assoc 10 (entget aab)))))
     ))
     (cond ((= bb "CIRCLE")
           (setq pd (list aab (cdr (assoc 10 (entget aab)))))
     ))
     (cond ((= bb "ARC")
           (setq pd (list aab (cdr (assoc 10 (entget aab)))))
     ))    
(cond ((= i 0)
(setq j 0)
(cond ((= j 0)
(cond ((/= bb "LINE")
(setq aad 0)))
(cond ((/= bb "CIRCLE")
(setq bad 0)))
(cond ((/= bb "ARC")
(setq cad 0)))))))
(setq j (+ j 1))
(cond ((= bb "LINE")
(setq st (cdr (assoc 11 (entget aab))))
(setq qed (cdr (assoc 10 (entget aab))))
(setq ad (distance st qed))
(cond ((= i 0)
(setq aad ad)))
(cond ((>= i 1)
(setq aad (+ ad aad))))
))            
(cond ((= bb "CIRCLE")
  (setq aeed (cdr (assoc 40 (entget aab))))
  (setq ad (* aeed pi 2.0))
(cond ((= i 0)
(setq bad ad)))
(cond ((>= i 1)
(setq bad (+ ad bad))))
))
(cond ((= bb "ARC")
  (setq ast (cdr (assoc 50 (entget aab))))
  (setq sst (cdr (assoc 51 (entget aab))))
  (setq beed (cdr (assoc 40 (entget aab))))
(cond ((>= ast 0)
(cond ((< ast p)
(cond ((> ast sst)
(cond ((>= (* pi 2.0))
(setq xb (- ast sst))))
(cond ((> sst 0)
(setq xb1 (- p ast))
(setq xb (+ g xb1 sst))))))
(cond ((< ast sst)
(cond ((>= sst 0)
(setq xb1 (- p ast))
(setq xb (+ pi xb1 sst))))
(cond ((< sst (* pi 2.0))
(cond ((< sst p)
(setq xb (- sst ast))))
(cond ((< sst pi)
(setq xb1 (- p ast))
(setq xb2 (- sst p))
(setq xb (+ xb1 xb2))))
(cond ((< sst g)
(setq xb1 (- p ast))
(setq xb2 (- sst pi))
(setq xb (+ xb1 xb2 p))))
(cond ((< sst (* pi 2.0))
(setq xb1 (- p ast))
(setq xb2 (- sst g))
(setq xb (+ xb1 xb2 pi))))
))
))
))))
(cond ((>= ast p)
(cond ((< ast pi)
(cond ((> ast sst)
(cond ((<= sst p)
(setq xb1 (- ast p))
(setq xb2 (- p sst))
(setq xb (- (* pi 2.0)xb1 xb2))))
(cond ((> sst p)
(setq xb (- (* pi 2.0)(- ast sst)))))))
(cond ((< ast sst)
(setq xb (- sst ast))))
))))


(cond ((>= ast pi)
(cond ((< ast g)
(cond ((> ast sst)
(cond ((> sst 0)
(setq xb2 sst)
(setq xb1 (- g ast))
(setq xb (+ xb1 xb2 p))))
(cond ((>= sst p)
(setq xb1 (- ast pi))
(setq xb2 (- pi sst))
(setq xb (- (* pi 2.0) xb1 xb2))))
(cond ((>= sst pi)
(setq xb1 (- g ast))
(setq xb2 (- sst pi))
(setq xb (+ g xb1 xb2))))
(cond ((> sst g)
(setq xb1 (- sst pi))
(setq xb2 (- g ast))
(setq xb (+ xb1 xb2 g))))
))
(cond ((< ast sst)
(setq xb (- sst ast))))
))))
(cond ((>= ast g)
(cond ((< ast (* pi 2.0))
(cond ((> ast sst)
(cond ((>= sst g)
(setq xb1 sst)
(setq xb2 (- (* pi 2.0)ast))
(setq xb (+ xb1 xb2))))
(cond ((< sst g)
(setq xb1 (- sst g))
(setq xb2 (- (* pi 2.0)ast))
(setq xb (+ g xb1 xb2))))
))
(cond ((< ast sst)
(setq xb (- sst ast))))
))))
(setq ad (* beed xb))
(cond ((= i 0)
(setq cad ad)))
(cond ((>= i 1)
(setq cad (+ ad cad))))
))
  (setq i (+ 1 i)))
(setq aaad (+ aad bad cad))
(setq ai aaad)
(setq aai (rtos ai 2 4))
(setq abi "<")
(setq aci ">")
(setq adi "线段总长为:")
(princ (strcat adi abi aai aci))
(command "pickbox" 3)
(princ)
)

pengfei2010

回帖是一种美德！感谢楼主的无私分享 谢谢

zylaser

如果这个程式好的话，请大家给我留一下言，不好就请大家给我提一下意见，好让我有所改进，如果大家都看不提意见，我会很失望的，从某些方面讲，明经就是需要大家的意见，这样网站才会有人气，才会兴望，只有不断的交流，大家的知识才会进步，

mccad

但不是对所有的线有效，如样条曲线、多段线、优化多段线等。
这里有一个贴子你看看吧：
http://www.mjtd.com/bbs/dispbbs.asp?boardID=3&RootID=16564&ID=16564
是计算任意曲线的长度，刚好可以补充实用函数栏目中所缺少的内容。

龙龙仔

caravaggio

zpqcq

谢谢,好用

AMTONNY

偶点个位置

董堃

(defun c:sj()
(princ "\n选取要计算的图元计算线长<总长>:")
(setq ss (ssget))
(setq n 0)
(setq yy 0)
(repeat (sslength ss)
(setq ssn (ssname ss n))
(command "lengthen" ssn "")
(setq dd (getvar "perimeter"))
(setq n (1+ n))
(setq yy(+ yy dd)))
(setq pt (getpoint "\n文字位置点: "))
(setq old_hh (getvar "textsize"))
(setq str_hh (strcat "\n高度 <" (rtos old_hh 2) ">: "))
(setq hh (getdist pt str_hh))
(if (null hh) (setq hh old_hh))
(command "text" pt hh 0 (strcat "总长=" (rtos yy 2 2) "MM"))
(prin1)
)

FANGZHENG158

谢谢,好用

ayong8397

好东西,谢谢了!