[下载]工程计算好用的lisp分享

Michael527

;~~~~~~~~~~~~~~~~~~改变所有字型型式(cf)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(defun c:cf()
(setq hh(getstring "请输入font style:" ))
(setq ss (ssget "X" '((0 . "TEXT"))))
(setq i 0)
(repeat (sslength ss)
(setq ssn (ssname ss i))
(setq ssdata (entget ssn))
(setq old_hh (assoc 7 ssdata))
(setq new_hh (cons 7 hh))
(setq ssdata (subst new_hh old_hh ssdata))
(entmod ssdata)
(setq i (1+ i))
)
  )
;~~~~~~~~~~~~~~~~~~改变所有字型型式(cf)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;~~~~~~~~~~~~~~~~~~改变所有text的高度(ch)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(defun c:ch()
(prompt "***改TEXT可用***更改图面text高度")
(setq oldh(getreal "\n请输入欲修改文字的高度<全部text都改直接按enter>:" ))
(setq newh(getreal "\n请输入修改后文字高度:" ))
(if (= oldh nil)  
  (progn
  (setq ss (ssget "X" '((0 . "TEXT"))))
  (setq i 0)
     (repeat (sslength ss)
     (setq ssn (ssname ss i))
     (setq ssdata (entget ssn))
     (setq old_hh (assoc 40 ssdata))
     (setq new_hh (cons 40 newh))
     (setq ssdata (subst new_hh old_hh ssdata))
     (entmod ssdata)
     (setq i (1+ i))
     );end repeat
   );end progn
  (progn
  (setq ss(ssget "X" (list(cons 0 "TEXT")(cons 40 oldh))))
  (setq i 0)
     (repeat (sslength ss)
     (setq ssn (ssname ss i))
     (setq ssdata (entget ssn))
     (setq old_hh (assoc 40 ssdata))
     (setq new_hh (cons 40 newh))
     (setq ssdata (subst new_hh old_hh ssdata))
     (entmod ssdata)
     (setq i (1+ i))
     )
   )  
);end if
  )
;~~~~~~~~~~~~~~~~~~改变所有text的高度(ch)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

;~~~~~~~~~~~~~~~~~~替代文字内容(ct)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(defun c:ct()
(prompt "***改TEXT可用***此指令将图档内所有文字替换 如:将所有的~碳纤~文字 替换成~碳纤维~文字 ")
(setq oldtxt (getstring t "\n请输入原始文字内容:"))
(setq newtxt (getstring t "\n请输入更变后文字内容:"))      
  ;(ssget "x" '((-4 . "<not")(-4 . "<or")(62 . 1)(62 . 5)(-4 . "or>")(-4 . "not>")))
   ;~~~~~~text型式的文字~~~~~~~~~~
   (setq ss(ssget "X" '((0 . "text"))))
   (setq oldnum (strlen oldtxt));旧字串长度
   (setq newnum (strlen newtxt));新字串长度
   (setq i 0)
   (repeat (sslength ss)
      (setq ssn (ssname ss i))
      (setq ssdata (entget ssn))
      (setq sstyp (cdr (assoc 0 ssdata)))
            (setq p 1)
            (setq ent (assoc 1 ssdata))
            (setq entxt (cdr ent))
            (setq ennum (strlen entxt))
            (setq aa "")
            (while (<= p ennum)
               (setq kk (substr entxt p oldnum))
               (if (= kk oldtxt)
                   (progn
                      (setq kk newtxt)
                      (setq p (- (+ p oldnum) 1))
                   )
                   (setq kk (substr entxt p 1))
               );end if
               (setq aa (strcat aa kk))
               (setq p (1+ p))
             );end while
             (setq aa (cons 1 aa))
             (setq ssdata (subst aa ent ssdata))
             (entmod ssdata)
       (setq i (1+ i))
   );end repeat
    ;~~~~~~text型式的文字****到此结束~~~~~~~~~~
  ;~~~~~~Mtext型式的文字~~~~~~~~~~
    (setq ssm(ssget "X" '((0 . "MTEXT"))))
   (setq oldnum (strlen oldtxt))
   (setq newnum (strlen newtxt))
   (setq j 0)
   (repeat (sslength ssm)
      (setq ssn (ssname ssm j))
      (setq ssdata (entget ssn))
      (setq sstyp (cdr (assoc 0 ssdata)))
   
         
            (setq p 1)
            (setq ent (assoc 1 ssdata))
            (setq entxt (cdr ent))
            (setq ennum (strlen entxt))
            (setq aa "")
            (while (<= p ennum)
               (setq kk (substr entxt p oldnum))
               (if (= kk oldtxt)
                   (progn
                      (setq kk newtxt)
                      (setq p (- (+ p oldnum) 1))
                   )
                   (setq kk (substr entxt p 1))
               )
               (setq aa (strcat aa kk))
               (setq p (1+ p))
             )
             (setq aa (cons 1 aa))
             (setq ssdata (subst aa ent ssdata))
             (entmod ssdata)
       (setq j (1+ j))
   );end repeat
)        
         
;
;~~~~~~~~~~~~~~~~~~替代文字内容(ct)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;~~~~~~~~~~~~~~~~~~改变线宽内容(cw)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
(defun c:cw()
   (setvar "cmdecho" 0)
   (setq ww (getdist "\n宽度 <1>: "))
   (if (= ww nil) (setq ww 1.0))
   (setq ss (ssget))
   (setq s 0)
   (repeat (sslength ss)
      (setq ssn (ssname ss s))
      (setq entyp (cdr (assoc 0 (entget ssn))))
      (cond ((= entyp "CIRCLE") (progn
          (setq rr (cdr (assoc 40 (entget ssn))))
          (setq cen (cdr (assoc 10 (entget ssn))))
          (command "donut" (* 2 (- rr (/ ww 2))) (* 2 (+ rr (/ ww 2))) cen "")
          (command "erase" ssn "")
          ))
          ((= entyp "LINE") (command "pedit" ssn "y" "w" ww ""))
          ((= entyp "ARC") (command "pedit" ssn "y" "w" ww ""))
          ((= entyp "LWPOLYLINE") (command "pedit" ssn "w" ww ""))
          ((= entyp "POLYLINE") (command "pedit" ssn "w" ww ""))
      )
      (setq s (1+ s))
    )
)
;~~~~~~~~~~~~~~~~~~改变线宽内容(cw)~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
;********************将选择text数字加总(to)************
(defun c:to(/ ce i data1 textcont totaltext totaldec seltext ssn1)
(setq ce(getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq totaltext 0)
(setq seltext "")
(setq ssn1(entsel "\n请选取欲加总文字1(text):"))
(setq i 2)
(redraw (car ssn1) 3);Highlight entity
   (while (/= ssn1 nil)
     (setq data1(entget (car ssn1)))
     (setq textcont(cdr (assoc 1 data1)))
     (setq totaltext(+ totaltext (atof textcont)) )
     (setq totaldec(rtos totaltext 2 0))
     (setq seltext(strcat seltext "+" textcont ))
     (setq ssn1(entsel (strcat "\n请选取欲加总文字" (rtos i 2 2) "(text):")))
       (if (/= ssn1 nil)
       (redraw (car ssn1) 3);Highlight entity
       );end if
     ;(setq ssn1 ssn2)
     (setq i(+ i 1))
   );end while
  
  (setq result(strcat seltext "=" totaldec))
  (command "text" pause "" "" result)
;(princ result)
; (setvar "cmdecho" ce)

  );end defun

;********************将选择text数字加总(to)************
;********************将面积写出成text(atx)************
(defun c:atx ()
;(command "style" "romans" "romans" "0" "1" "0" "n" "n" "n")
(setq ce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "area" "e" pause)
(setq v1(rtos(getvar "area")2 0));取得面积 Perimeter取得周长
(setvar "cmdecho" ce)
(command "text" pause "" "" v1 "")
);end defun
(prompt "\n(to)  将选择text数字加总")
(prompt "\n(atx) 将面积写出成text")
;********************将面积写出成text(atx)************
;********************将周长写出成text(ltx)************
(defun c:ltx ()
(command "style" "romans" "romans" "0" "1" "0" "n" "n" "n")
(setq ce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "area" "e" pause)
(setq v1(rtos(getvar "perimeter")2 0));取得面积 Perimeter取得周长
(setvar "cmdecho" ce)
(command "text" pause "" "" v1 "")
);end defun
(prompt "\n(to)  将选择text数字加总")
(prompt "\n(ltx) 将长度写出成text")
(prompt "\nCreated by charchin lin 2001 Dec")
;********************将周长写出成text(ltx)************
;****************将选取文字写出至txt档(wf)*********************
  (defun c:wf()
  (setq dat_file (getfiled "写档" "c:\\temp\\text1" "txt" 1))
  
   ;(setq en1(entsel "\n请点选第1个文字<按Esc键取消><按enter换行>:"))
    ;(redraw (car en1) 3);Highlight entity
   
    (setq i 2 )
    (while (> i 1)
         (setq ff (open dat_file "a"))
          (setq stick "")
          (setq en1(entsel "\n请点选第1个文字<按Esc键取消><按enter换行>:"))
          (redraw (car en1) 3);Highlight entity
               (while (/= en1 nil)
            (setq data1(entget (car en1)))
            (setq s1t(cdr (assoc 1 data1)))
            (setq newstring(strcat "," s1t))
            (setq stick(strcat stick newstring));累积串
            (setq en1(entsel "\n请点选下一个文字<按Esc键取消><按enter换行>:"))
             (if (/= en1 nil)
             (redraw (car en1) 3);Highlight entity
             );end if
            (setq i 5)
          );end while
            (write-line stick ff)
            (close ff)
            (setq i 3)
     );end while
      
   ; (prin1)
    );end defun
    (prompt "Created by charchin lin 2001 Dec")
;****************将选取文字写出至txt(wf)*********************
;***************选点写出x,y座标(xy)*****************
(defun c:xy()
(setq point(getpoint "点选位置:"))
(setq crad(getreal "输入半径or字高:"))
(setq osnap_v(getvar "osmode")) ;取出osnap值
(setvar "osmode" 0 );并且关闭 以免影响lisp图
(setq tpoint1(polar point (* -0.25 pi) (* 1.8 crad)) )
(setq tpoint2(polar point (* -0.361 pi) (* 3 crad))  )   
(setq tpx(strcat "E=" (rtos(car point) 2 3) ));
(setq tpy(strcat "N=" (rtos(cadr point) 2 3) ));
(command "point" point)  
(command "text" tpoint2 crad "" tpx )
(command "text" tpoint1 crad "" tpy )
;(circ point crad)

(setvar "osmode" osnap_v );恢复原来抓点模式设定  
  (while (/= point nil)
       (setq point(getpoint "点选位置:"))
       (setq osnap_v(getvar "osmode")) ;取出osnap值
       (setvar "osmode" 0 );并且关闭 以免影响lisp图
         (setq tpoint1(polar point (* -0.25 pi) (* 1.8 crad)) )
        (setq tpoint2(polar point (* -0.361 pi) (* 3 crad))  )   
        (setq tpx(strcat "E=" (rtos(car point) 2 3) ));
        (setq tpy(strcat "N=" (rtos(cadr point) 2 3) ));
        (command "point" point)  
        (command "text" tpoint2 crad "" tpx )
        (command "text" tpoint1 crad "" tpy )
       ;(circ point crad)
       (setvar "osmode" osnap_v );恢复原来抓点模式设定
    );end while
  (setvar "osmode" osnap_v );恢复原来抓点模式设定
)
;***************选点写出x,y座标(xy)*****************

Michael527

;****************副涵数 输入 座标及半径 划出圆及中心十字*********************
(defun circ(cp rad)
(setq x1(- (car cp) (* 2 rad)))
(setq y1(cadr cp))
(setq pt1(list x1 y1))
(setq x2(+ (car cp) (* 2 rad)))
(setq pt2(list x2 y1))
(setq y3(+ (cadr cp) (* 2 rad)))
(setq x3(car cp))
(setq pt3(list x3 y3))
(setq y4(- (cadr cp) (* 2 rad)))
(setq pt4(list x3 y4))
(setq x11(- (car cp) rad))
(setq y11(cadr cp))  
(setq pt5(list x11 y11));pt5&pt6为圆直径
(setq x12(+ (car cp) rad))      
(setq pt6(list x12 y11));pt5&pt6为圆直径   
(command "line" pt1 pt2 "")
(command "line" pt3 pt4 "")
(command "circle" cp rad);圆  
)
;****************副涵数 输入 座标及半径 划出圆及中心十字*********************
;****************n1文字加编号(如:b2f-1 b2f-2)*********************
(defun c:n1()
  (setvar "cmdecho" 0)
  (setq ldft(getvar "textsize"))
  (setq sizet (getreal (strcat "\n文字大小? <" (rtos ldft 2 2) ">: ")))
  (if (= sizet  nil)(setq sizet ldft))
  (setvar "textsize" sizet)

  (prompt "***文字加编号(如:b2f-1 b2f-2 b2f-2)")
  (setq i(getint "\n输入起始值<按enter=1>:"))
  (if (= i nil)
    (setq i 1)
    );end if
  (setq front(getstring "\n欲加入字串(数字前)<不要加按enter>:"))
  (setq ldf(getvar "clayer") )
  
    (if (/= ldf "stext")
       (progn  (command "layer" "n" "stext" "c" "1" "stext" "" )
               (command "layer" "s" "stext" "" ) );end progn
    );end if
   (setq sp(getpoint "\n点选位置点:"))
   (setq stri(strcat front (itoa i) ))
   (command "text" sp "" "" stri )
   ;(command "layer" "n" "cir" "" )
    (while (/= sp nil)
       (setq i(1+ i))
       (setq sp(getpoint "\n点选位置点:"))
       (if (/= sp nil)
         (progn
           (setq stri(strcat front (itoa i) ))
           (command "text" sp "" "" stri )
          );end progn
       );end if
     ; (command "layer" "s" "cir" "" )
     ; (command "circle" sp (* 1.3 ldft) )
      
    );end while
  (setvar "clayer" ldf )
  (prompt "Created by charchin lin 2001 Dec")
  (prin1)
)
;****************n1文字加编号(如:b2f-1 b2f-2)*********************


;********************将长度写出成text(ltx)************
(defun c:ltx()
(setq ce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "area" "e" pause)
(setq v1(rtos(getvar "Perimeter")2 0));取得面积 Perimeter取得周长
(setvar "cmdecho" ce)
(command "text" pause "" "" v1)
);end defun
(prompt "\n(to)  将选择text数字加总")
(prompt "\n(areatx) 将长度写出成text")
(prompt "\nCreated by charchin lin 2001 Dec")
;********************将长度写出成text(areatx)************
;********************方向线角度值************
(defun c:cv()
(setvar "cmdecho" 0)

;(getvar a("angdir"));0逆时钟 1顺时钟
(setq spoint(getpoint "\输入起点:"))
(command "line" spoint pause   "")
(setq ent(entlast))
(setq ent1(entget ent))
(setq epoint(cdr (assoc 11 ent1)));终点  
;(command "aunits" 1); 0十进位 1度分秒 2分度 3弪度 4土地测量位  
;(command "auprec" 3);角度小数点位数  
;(command "luprec" 3);长度小数点数
  
;(setq ang(angtos (angle spoint epoint) 1 4));0度 1度分秒 2分度量 3弪度 4测位
(setq angv(angle spoint epoint) );*57.2958279 弪度转角度
(setq dist(rtos (distance spoint epoint) 2 3));1科学 2十进位
;***************角度转换成方位角***********************
       (cond
         ( (and (<= angv 1.5707963)(> angv 0)) (setq ang(angtos (- 1.5707963 angv) 1 4)) );
         ( (and (<= angv 3.1415926)(> angv 1.5707963)) (setq ang(angtos (- 7.8539816 angv) 1 4)) )
         ( (and (<= angv 4.7123890)(> angv 3.1415926))  (setq ang(angtos (- 7.8539816 angv) 1 4)) )
         ( (and (<= angv 6.2831853)(> angv 4.7123890))  (setq ang(angtos (- 7.8539816 angv) 1 4)) )
         ( (= angv 0)  (setq ang(angtos (- 1.5707963 angv) 1 4)) )
        );end cond
  (setq ta(*  angv  57.2958279))
(setq angstr(strcat "Angle=" ang))
(setq distext(strcat "Dist=" dist))
(setq offd(/ (getvar "textsize") 2 ));字离线的最短距离
(setq dh(atan offd (/ (distof dist) 2)  )  );算出角度

(command "style" "romans" "romans" "0" "1" "0" "n" "n" "n")
(setq osnap_v(getvar "osmode")) ;取出osnap值
(setvar "osmode" 0 );并且关闭 以免影响lisp绘图   
(command "text" (polar spoint (+ angv dh) (/ (distof dist) 2) ) "" ta distext );文字的位置由dh角度去决定
(command "text" (polar spoint (- angv (* 3 dh)) (/ (distof dist) 2) ) "" ta angstr )   
(setvar "osmode" osnap_v );恢复原来抓点模式设定
);end defun
;********************方向线角度值******************
;********************将长度写出成text(qq)加上支数************
(defun c:qq()
(setq ce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq q(getint "多少支数<enter>"))
  (if (= q nil)
    (setq q bb)
    (progn
      (setq q(rtos q))
      (setq bb q)
      )
    )
(command "area" "e" pause)
(setq b1(rtos(getvar "Perimeter")2 0));取得面积 Perimeter取得周?
(setq v1(strcat b1 "x"  q ))
(setvar "cmdecho" ce)
(command "text" pause "" "" v1)
);end defun
(prompt "\n(to)  将选择text数字加总")
(prompt "\n(areatx) 将长度写出成text")
(prompt "\nCreated by charchin lin 2001 Dec")
;********************将长度写出成text(qq)加上支数************
;(prompt "\nCreated by charchin lin(林志青) 2001 Dec E-MAIL:watts_lin@yahoo.com.tw")

;********************快速bhatch***************
(defun c:bb()
   (setq ldfs(getvar "hpspace"))
  (setq dd (getdist (strcat "\n剖面间距? <" (rtos ldfs 2 2) ">: ")))
  (if (= dd nil) (setq dd ldfs ))
  (setq ang (getangle "\n剖面角度<45>:"))
  (if (= ang nil) (setq ang (/ pi 4)))
  ;(initget  "Y N")
  ;(setq dbu (getkword "\n双重剖面Y/N <N>:"))
  ;(if (= dbu nil) (setq dbu "N"))
  (setvar "hpname" "u")
  (setvar "hpspace" dd)
  (setvar "hpang" ang)
  (setvar "hpdouble" 0)
    ;(if (= (strcase dbu) "Y")
      ; (setvar "hpdouble" 1)
     ;  (setvar "hpdouble" 0)
    ; )
  (setq pt (getpoint "\n选取内部点:"))
  (while (/= pt nil)
     (command "-bhatch" pt "")
      (setq pt (getpoint "\n选取内部点:"))
   
   
  );end while
)
;********************快速bhatch***************(defun c:tt(/ ce i data1 textcont  totaldec seltext ssn1)
;********************设定字高***************
(defun  c:ts(/ texts tsn txt)
(setq  tsn(getvar "textsize"))
(setq txt(strcat "\n请输入字高:" "<" (rtos tsn 2 ) ">:" ))
(setq texts(getreal txt) )
(if (= texts nil) (setq texts tsn))
   (setvar "textsize" texts)
); end defun
;********************设定字高***************
   
(defun c:tt(/ ce i data1 textcont  totaldec seltext ssn1)
(setq ce(getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq totaltext 0)
(setq seltext "")
(setq ssn1(entsel "\n请选取欲加总文字1(text):"))
(setq i 2)
(redraw (car ssn1) 3);Highlight entity
   (while (/= ssn1 nil)
     (setq data1(entget (car ssn1)))
     (setq textcont(cdr (assoc 1 data1)))
     (filterm textcont)

     ;(setq totaltext(+ totaltext (atof textcont)) )
     (setq totaltext(+ totaltext (atof p5)) )
     (setq totaldec(rtos totaltext 2 0))
     (setq seltext(strcat seltext "+" (rtos (atof p5) 2 0) ))
     (setq ssn1(entsel (strcat "\n请选取欲加总文字" (rtos i 2 2) "(text):")))
       (if (/= ssn1 nil)
       (redraw (car ssn1) 3);Highlight entity
       );end if
     ;(setq ssn1 ssn2)
     (setq i(+ i 1))
   );end while
  
  (setq result(strcat seltext "=" totaldec))
  (command "text" pause "" "" result)
;(princ result)
; (setvar "cmdecho" ce)
  (prompt "\nCreated by charchin lin 2001 Dec ***取消高亮度请输入regen***")
  );end defun


(defun c:areatx ()
(setq ce (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "area" "e" pause)
(setq v1(rtos(getvar "area")2 0));取得面积 Perimeter取得周长
(setvar "cmdecho" ce)
(command "text" pause "" "" v1)
);end defun
(prompt "\n(to)  将选择text数字加总")
(prompt "\n(areatx) 将面积写出成text")
(prompt "\nCreated by charchin lin 2001 Dec")



(defun filterm(data )

   
   
      
      (setq p1 "" p2 ""  p3 '() p4 "" i 1)
      (setq nn (strlen data))
      (setq p1 (substr data i 1))
      (setq wh "")      
    (if    (= p1 "{") ;A
         (progn       ;1
               (repeat nn  ;1
                 (setq p1 (substr data i 1))
                 (if (= p1 ";" )
                      (setq q (+ 1 i))
                    );end if
                 (setq i (1+ i))
               );end repeat 1
                       
                    (repeat (- nn q )   ;2
                        (setq p1 (substr data q 1))
                        (if (/= p1 "}" )
                           (progn
                              (setq p2 (strcat p2 p1))
                               );end progn
                          );end if
                         (setq q (1+ q))
                      );end repeat 2
             
            );progn 1
         
      );end if
        (setq p5 p2);
        (setq p1 "" p2 ""  p3 '() p4 "" i 1 q 1)
        (setq p1 (substr data i 1))  
     (if  (/= p1 "{");B
       (progn

            (repeat nn  ;1
              (setq p1 (substr data i 1))
                (if (/= p1 "{") ;11
                      (if  (= p1 "}");e
                        (setq p1 "")      
                        (setq p2 (strcat p2 p1))
                        );e
                      (progn  ;p
                         (repeat  nn ;d
                         (setq p1 (substr data q 1))
                            (if (= p1 ";")
                                (setq i  q )
                             );
                              (setq q(1+ q))
                            );end repeat  d        
                      );progn p
                 );end if 11
                 (setq i(1+ i))
             ;(princ p2)       
            );end repeat 1
         (setq p5 p2); 字串变数p5
        );progn
      
        (progn
         
        );progn
      );end if b


  );end defun

lqss

干什么用的？

monkeylzx

多谢分享，来学习学习

风流少年时

不错的东西。

kx820506

干什么用的

springwillow

收了，试试

xiaxiang

没简体版的吗，望重新更新一下

/fendouKenn

汉字那部分，几乎都是乱码

ToXicBug

收藏了

谢谢