[LISP程序]：来了这么久，也该给大家做点贡献啦！！！

talkershadows

给大家提供一些我常用的lisp程序，



;在原地拷贝所选择的物体到当前层:
(defun c:cll ( / i ss el)
  (setq i 0)
  (if (setq ss (ssget))
      (repeat (sslength ss)
        (command "copy" (ssadd (ssname ss i)) "" '(0 0) "")
        (command "chprop" (entlast) "" "layer" (getvar "clayer") "")
        (setq i (1+ i))
      )
  )
  (prin1)
)
;^^^^^^ c:cll

;设置当前层为选择物体的所在层, 或由层清单选择:
;使用对话框pwnew.dcl/le
(defun c:le (/ show_color action_ll
               ent dcl_id layer_list layer_id hide_layers layer)

  (defun show_color (layer_name)
    (start_image "layer_color")
    (fill_image 0 0 (dimx_tile "layer_color") (dimy_tile "layer_color")
                (abs (cdr (assoc 62 (tblsearch "LAYER" layer_name))))
    )
    (end_image)
  )

  (defun action_ll ()
    (setq layer_id (atoi $value))
    (show_color (nth layer_id layer_list))
  )

  (if (setq ent (car (entsel)))
    ;由选取物体设置当前层
    (command "layer" "s" (cdr (assoc 8 (entget ent))) "")
    ;由层名表选择当前层
    (if (setq dcl_id (load_dialog "pwnew.dcl"))
      (progn
        (if (new_dialog "le" dcl_id)
          (progn
;           (princ "\nSelect layer :")
            (tblnext "LAYER" T)
            (setq layer_list '("0"))

            ;获取层名表
            (while (setq tbldata (tblnext "LAYER"))
              (setq layer_list (cons (cdr (assoc 2 tbldata)) layer_list))
            )

            (setq layer_list (acad_strlsort layer_list))

            ;计算某元素在表中的位置
            (setq layer_id (- (length layer_list)
                              (length (member (getvar "clayer") layer_list))
            ))

            (start_list "layer_list")
            (mapcar 'add_list layer_list)
            (end_list)
            (set_tile "layer_list" (itoa layer_id))
            (show_color (getvar "clayer"))
            (setq hide_layers 0)
            (action_tile "layer_list" "(action_ll)")
            (action_tile "hide_layers" "(setq hide_layers (atoi $value))")
            (action_tile "accept" "(done_dialog 0)")
            (action_tile "cancel" "(done_dialog 1)")
            (if (= 0 (start_dialog))
              (progn
                ;决定是否关闭其它所有层
                (if (= 1 hide_layers) (command "layer" "off" "*" "y" ""))
                (setq layer (nth layer_id layer_list))
                (command "layer" "t" layer "s" layer "")
              )
            )
          )
        )
        (unload_dialog dcl_id)
      )
    )
  )
  (prin1)
)
;^^^^^^ c:le

;在ACAD对话框中进行文本阅读
(defun c:read (/ fname dcl_id file_id tline tlist)
  (setq fname (getfiled "Load lisp file" "" "" 4))
  (if (= fname 1) (setq fname (getstring "\n Enter filename: ")))
  (if fname
    (if (findfile fname)
;^^输入文件名
      (if (setq dcl_id (load_dialog "pwnew.dcl"))
        (progn
          (setq file_id (open fname "r"))
          (while (setq tline (read-line file_id)) (setq tlist (append tlist (list tline))))
;^^将文件内容读入表tlist中
          (if tlist
            (if (new_dialog "read" dcl_id)
              (progn
                (start_list "content")
                (mapcar 'add_list tlist)
                (end_list)
;^^显示文件内容
                (start_dialog)
          )))
          (unload_dialog dcl_id)
      ))
      (prompt (strcat "\n Can't find file " (strcase fname)))
  ))
  (prin1)
)


;===================================================
;增强的offset命令，对Line、Arc、Polyline、Circle有效：
;在"Side to offset?"提示时用空回车可生成双线，并提示是否删除原有的实体
;其余功能完全保留offset命令原样
;===================================================
(defun c:os (/ osd ent ptt pt0 pt1 pt2 pt3 pt4 an kwd)
   (if (< (getvar "offsetdist") 0) (setq osd "Through") (setq osd (rtos (getvar "offsetdist"))))
   (initget 6 "Through")
   (setq osd (getreal (strcat "\nOffset distance or Through <" osd ">:")))
   (if (= osd "Through") (setq osd -1))
   (if (not osd) (setq osd (getvar "offsetdist")) (setvar "offsetdist" osd))
   (if (< osd 0)
      (while
         (if (setq ent (entsel "\nSelect object to offset:"))
            (progn
               (redraw (car ent) 3)
               (if (setq ptt (getpoint "\nThrough point:"))
                  T
                  (redraw (car ent))
               )
            )
         )            
         (command "offset" "" ent ptt "" "chprop" (entlast) "" "la" (getvar "clayer") "")
         (redraw (car ent))
      )
      (while
         (setq ent (entsel "\nSelect object to offset:"))
         (setq enp (cdr (assoc 0 (entget (car ent)))))
         (redraw (car ent) 3)
         (setq ptt (getpoint "\nSide to offset?"))
         (if ptt
            (command "offset" "" ent ptt "" "chprop" (entlast) "" "la" (getvar "clayer") "")
            (progn
               (setq pt0 (cadr ent))
               (setq pt1 (osnap pt0 "near"))
               (if (= enp "CIRCLE")
                  (setq pt3 (osnap pt0 "cen") pt4 (polar pt1 (+ (angle pt1 pt3) pi) (distance pt1 pt3)))
                  (setq pt2 (osnap pt0 "endp") an (angle pt1 pt2) pt3 (polar pt1 (- an (/ pi 2)) osd) pt4 (polar pt1 (+ an (/ pi 2)) osd))
               )
               (command "offset" "" ent pt3 "" "chprop" (entlast) "" "la" (getvar "clayer") "")
               (command "offset" "" ent pt4 "" "chprop" (entlast) "" "la" (getvar "clayer") "")
               (initget "Yes No")
               (setq kwd (getkword "\nDelete the original object? Yes/<No>?"))
               (if (= kwd "Yes") (entdel (car ent)))
            )
         )
         (redraw (car ent))
      )
   )
)

;=================================================
;选择一组LINE实体，在当前层绘制双线
;=================================================
(defun c:dbl (/ get ss i el pt1 pt2 an pa1 pa2 pb1 pb2)
   ;设置偏移量（半双线距离）,缺省为100,全局变量offsetdt
   (if (not offsetdt) (setq offsetdt 100))
   (initget 6)
   (setq get (getint (strcat "\n Enter the offset distance <" (itoa offsetdt) ">:")))
   (if (not get) (setq get offsetdt))
   (setq offsetdt get get nil)
   
   ;只对line作用
   (prompt "\n Select base lines:")
   (setq ss (ssget '((0 . "line"))))
   
   (setq i 0)
   (if ss
      (repeat (sslength ss)
         (setq el (entget (ssname ss i)))
         (setq pt1 (cdr (assoc 10 el)) pt2 (cdr (assoc 11 el)))
         (setq an (angle pt1 pt2))
         (setq pa1 (polar pt1 (+ an (/ pi 2)) offsetdt)
            pb1 (polar pt1 (- an (/ pi 2)) offsetdt)
            pa2 (polar pt2 (+ an (/ pi 2)) offsetdt)
            pb2 (polar pt2 (- an (/ pi 2)) offsetdt)
         )
         (entmake (list '(0 . "LINE") (cons 8 (getvar "clayer")) (cons 10 pa1) (cons 11 pa2)))
         (entmake (list '(0 . "LINE") (cons 8 (getvar "clayer")) (cons 10 pb1) (cons 11 pb2)))
         (setq i (1+ i))
      )
   )
   (princ)
)

;=================================================
;清理墙线交叉
;在需清理的交叉墙线上点取需要保留的墙线段，只见......
;=================================================
(defun c:dtr (/ dtr_upe dtr_line s el pt1 pt2 l n i a )
   (defun dtr_up (a l)
      (if (not l)
         (cons a l)
         (if (> (cdr a) (cdar l))
            (cons (car l) (dtr_up a (cdr l)))
            (if (= (cdr a) (cdar l)) l (cons a l))
         )
      )
   )
   
   (defun dtr_line (l la)
      (if (cdr l)
         (progn
            (entmake (list '(0 . "LINE") la (cons 10 (caar l)) (cons 11 (caadr l))))
            (dtr_line (cddr l) la)
         )
      )
   )
   
   (setq es (entsel "\n Pick a  line:"))
   (if (= "LINE" (cdr (assoc 0 (entget (car es)))))
      (progn
         (setq pt0 (trans (cadr es) 1 0) el (entget (car es)))
         (setq pt1 (cdr (assoc 10 el)) pt2 (cdr (assoc 11 el)))
         (command "undo" "g")
         (setvar "ucsicon" 0)
         (command "ucs" "e" es "ucs" "o" (trans pt0 0 1))
         (entdel (car es))
         ;  (setq ss (ssget "F" (list pt1 pt2) (list '(0 . "LINE") (assoc 8 el))))
         (setq ss (ssget "X" (list '(0 . "LINE") (assoc 8 el))))
         (setq l nil n 0 i 0)
         (if ss
            (progn
               (repeat (sslength ss)
                  (setq el (entget (ssname ss i)))
                  (if (setq pt3 (inters pt1 pt2 (cdr (assoc 10 el)) (cdr (assoc 11 el))))
                     (progn         
                        (setq a (cons pt3 (car (trans pt3 0 1))))
                        (setq l (dtr_up a l))
                        (if (< (car (trans pt3 0 1)) 0) (setq n (1+ n)))
                     )
                  )         
                  (setq i (1+ i))
               )
               (if (= 0 (rem n 2))
                  (dtr_line (cdr l) (assoc 8 el))  
                  (dtr_line l (assoc 8 el))
               )
            )
         )
         (command "ucs" "p" "ucs" "p")
         (setvar "ucsicon" 1)
         (command "undo" "e")
      )
      (prompt "\nSupport LINE only!")
   )
)

;=================================================
;开门窗洞，选择门窗块插入到当前层
;=================================================
(defun c:pwdr (/ read_topic get es el1 el2 pt0 ptt pt1 pt2 an pt3 pt4 pa1 pa2 pb1 pb2 get ss i ex dcl_id put_image action1 actions windoorl wdlist center bname)

   ;读取门窗列表
   (defun read_topic (topic fname / t f_id fline strl)
      (if (setq fname (findfile fname))
         (progn
            (setq f_id (open fname "r"))
            (while (not t)
               (if (not (setq fline (read-line f_id)))
                  (setq t 0)
                  (if (wcmatch fline (strcat "\\" topic)) (setq t 1))
               )
            )
            (if (= t 1)
               (while (not (wcmatch (setq fline (read-line f_id)) "`\\*"))
                  (if (and (/= fline "") (not (wcmatch fline "`;*")))
                     (setq strl (cons (strcase fline) strl))
                  )
               )
            )
            (close f_id)
         )
      )
      (if strl (reverse strl) strl)
   )
   
   (command "undo" "g")
   ;选定插入门窗洞的基准线
   (if (setq es (entsel "\n Select base line:"))
      (progn
         (setq pt0 (trans (cadr es) 1 0))
         (setq el1 (entget (car es)))
         (setq ll (cdr (assoc 8 el1)))
         (setvar "orthomode" 1)  
         (setvar "ucsicon" 0)
         (command "ucs" "e" es)
         
         (setq pt1 (cdr (assoc 10 el1)) pt2 (cdr (assoc 11 el1)))
         (if (> (distance pt0 pt1) (distance pt0 pt2)) (setq ptt pt1 pt1 pt2 pt2 ptt))
         (setq an (angle pt1 pt2))
         
         ;设定门窗洞宽度,缺省为1000,全程变量openningwid
         (if (not openningwid) (setq openningwid 1000))
         (initget 70)
         (if (setq get (getint (strcat "\n Enter openning width:<" (itoa openningwid) ">"))) (setq openningwid get))
         
         ;设定门窗洞基线偏移量,缺省为100,全程变量offsetbase
         ;偏移量计算值为get
         ;对居中插入的情况计算偏移量get,不改变offsetbase的缺省值
         (if (not offsetbase) (setq offsetbase 100.0))
         (initget 70 "Middle")
         (setq get (getdist (trans pt1 0 1) (strcat "\n Base point offset distance/Middle/:<" (rtos offsetbase) ">")))
         (if get
            (if (= get "Middle")
               (setq get (/ (- (abs (distance pt1 pt2)) openningwid) 2))
               (setq offsetbase get)
            )
            (setq get offsetbase)
         )
         (setq pt0 (polar pt1 an get))
         
         ;获取与基准线平行的另一侧墙线  
         (initget 33)
         (setq ptt (trans (getpoint "\n" (trans pt0 0 1)) 1 0))
         (setq ss (ssdel (car es) (ssget "F" (list pt0 ptt) (list '(0 . "LINE") (cons 8 ll)))))
         (setq ex nil i 0)
         (while (and (not ex) (ssname ss i))
            (setq el2 (entget (ssname ss i)))
            (setq pt3 (cdr (assoc 10 el2)) pt4 (cdr (assoc 11 el2)))
            (if (not (inters pt1 pt2 pt3 pt4 nil)) (setq ex T))
         )
         
         ;找到另一侧墙线后开出门窗洞
         (if ex
            (progn
               (setq pa1 pt0
                  pa2 (polar pa1 an openningwid)
                  pb1 (inters pt0 ptt pt3 pt4)
                  pb2 (polar pb1 an openningwid)
               )
               (if (not (equal an (angle pt3 pt4) 1e-16)) (setq ptt pt3 pt3 pt4 pt4 ptt))
               (entdel (cdr (assoc -1 el1)))
               (entdel (cdr (assoc -1 el2)))
               (entmake (list '(0 . "LINE") (cons 8 ll) (cons 10 pt1) (cons 11 pa1)))
               (entmake (list '(0 . "LINE") (cons 8 ll) (cons 10 pa1) (cons 11 pb1)))
               (entmake (list '(0 . "LINE") (cons 8 ll) (cons 10 pb1) (cons 11 pt3)))
               (entmake (list '(0 . "LINE") (cons 8 ll) (cons 10 pt2) (cons 11 pa2)))
               (entmake (list '(0 . "LINE") (cons 8 ll) (cons 10 pa2) (cons 11 pb2)))
               (entmake (list '(0 . "LINE") (cons 8 ll) (cons 10 pb2) (cons 11 pt4)))
            )
         )
         
         ;通过对话框获取需插入的门窗块名
         (defun put_image (l / n i imgkey)
            (setq n (length l) i 0)
            (repeat 12
               (setq imgkey (strcat "I" (itoa i)))
               (start_image imgkey)
               (fill_image 0 0 (dimx_tile imgkey) (dimy_tile imgkey) 0)
               (end_image)
               (setq i (1+ i))
            )
            (setq i 0)
            (repeat n
               (setq imgkey (strcat "I" (itoa i)))
               (mode_tile imgkey 0)
               (start_image imgkey)
               (slide_image 0 0 (dimx_tile imgkey) (dimy_tile imgkey) (strcat "PWDR(" (nth i l) ")"))
               (end_image)
               (setq i (1+ i))
            )
            (setq i 11)
            (repeat (- 12 n)
               (setq imgkey (strcat "I" (itoa i)))
               (mode_tile imgkey 1) (setq i (1- i))
            )
         )
         
         (defun action1 ()
            (put_image (nth (atoi $value) wdlist))
            (if (= "2" $value)
               (progn (setq center 2) (set_tile "center" "1") (mode_tile "center" 1))
               (progn (setq center (atoi (get_tile "center"))) (mode_tile "center" 0))
            )
         )
         
         (defun actions ()
            (setq bname (nth (atoi (substr $key 2)) (nth (atoi (get_tile "windoor")) wdlist)))
            (cond
               ((wcmatch (strcase bname) "*C") (setq center 1) (set_tile "center" "1"))
               ((wcmatch (strcase bname) "*S") (setq center 0) (set_tile "center" "0"))   
            )
         )
         
         
         (setq windoorl '("DOORs01" "DOORs02" "WINDOWs"))
         (foreach i windoorl (setq wdlist (cons (read_topic i "pwdr.lst") wdlist)))
         (setq wdlist (reverse wdlist))
         (setq center 0)
         (setq dcl_id (load_dialog "pwdr.dcl"))
         (new_dialog "PWDR" dcl_id)
         (start_list "windoor")
         (mapcar 'add_list windoorl)
         (end_list)
         (set_tile "windoor" "0")
         (set_tile "center" "0")
         (put_image (car wdlist))
         
         (action_tile "windoor" "(action1)")
         (action_tile "center" "(setq center (atoi $value))")
         (action_tile "I0" "(actions)")
         (action_tile "I1" "(actions)")
         (action_tile "I2" "(actions)")
         (action_tile "I3" "(actions)")
         (action_tile "I4" "(actions)")
         (action_tile "I5" "(actions)")
         (action_tile "I6" "(actions)")
         (action_tile "I7" "(actions)")
         (action_tile "I8" "(actions)")
         (action_tile "I9" "(actions)")
         (action_tile "I10" "(actions)")
         (action_tile "I11" "(actions)")
         (action_tile "cancel" "(done_dialog 0)")
         (action_tile "accept" "(done_dialog 1)")
         
         (if (= 1 (start_dialog))
            (progn
               ;根据所选的门窗块名插入相应的图块
               (cond
                  ;靠墙一侧开启的门
                  ((= center 0)
                     (command "ucs" "3" (trans pa1 0 1) (trans pa2 0 1) (trans pb1 0 1))
                     (setq sc_x (car (trans pa2 0 1)) sc_y (cadr (trans pb1 0 1)))
                     (setq sc_y (* (abs sc_x) (if (minusp sc_y) 1 -1)))
                     (command "insert" bname '(0 0 0) "xyz" sc_x sc_y 1 "")
                     (initget "Yes No")
                     (if (= "Yes" (getkword "Mirror the Door? (yes/NO)"))
                        (command "mirror" (entlast) "" (mapcar '/ (trans pb1 0 1) '(1 2 1)) (mapcar '/ (trans pb2 0 1) '(1 2 1)) "y")
                     )
                     (command "ucs" "p")
                  )
                  ;居墙中开启的门
                  ((= center 1)
                     (command "ucs" "3" (trans pa1 0 1) (trans pa2 0 1) (trans pb1 0 1))
                     (setq sc_x (car (trans pa2 0 1)))
                     (command "insert" bname (mapcar '/ (trans pb1 0 1) '(1 2 1)) sc_x "" "")
                     (command "ucs" "p")
                  )
                  ;窗，有两个方向的比例
                  ((= center 2)
                     (command "ucs" "3" (trans pa1 0 1) (trans pa2 0 1) (trans pb1 0 1))
                     (setq sc_x (car (trans pa2 0 1)) sc_y (cadr (trans pb1 0 1)))
                     (command "insert" bname '(0 0 0) "xyz" sc_x sc_y 1 "")
                     (command "ucs" "p")
                  )
                  
               )
            )
         )
         (setvar "ucsicon" 1)
         (command "ucs" "p")
         (command "undo" "e")
      )
   )

JOSDENNIS

嘩!  好長的碼碼. 我用本本記下來慢慢學習. 樓主對LISP蠻有研究哦.