[编程交流] 非常健壮的lisp

 ;    .: Nozzle & Equipment Tags :.
 ;
 ;        .: by Lee McDonnell :.
(defun c:tktag2     (/ *error* dwgscal tagpt tagline linent linest    linend tagang cnt tcirc    tagcnt tagtxt tcirccent)
 (princ "\nInitialising...")
 (defun *error*  (msg)
   (if    oldVars
     (mapcar 'setvar varLst oldVars))
   (if    (eq msg "")
     (princ "\n<< Function Complete >>")
     (princ (strcat "Error: " (strcase msg))))
   (princ))
 (setq    varLst    (list "CMDECHO" "OSMODE" "CLAYER" "DIMSCALE")
   oldVars    (mapcar 'getvar varLst))
 (setvar "cmdecho" 0)
 (if (not (tblsearch "LAYER" "TAGLINE"))
   (command "-layer" "m" "TAGLINE" "c" "5" "TAGLINE" ""))
 (if (not (tblsearch "LAYER" "TEXT"))
   (command "-layer" "m" "TEXT" "c" "2" "TEXT" ""))
 (initget 7)
 (if (setq dwgscal (getreal "\nType Drawing Scale: 1:"))
   (progn
     (setvar "clayer" "TAGLINE")
     (while
   (/= (setq tagpt (getpoint "\nSelect First Tag Point: ")) nil)
    (prompt "\nSpecify Other Tag Points: ")
    (command "_line" tagpt)
    (while (> (getvar 'CmdActive) 0) (command pause))
    (setq tagline (entlast)
          linent  (entget tagline)
          linest  (cdr (assoc 10 linent))
          linend  (cdr (assoc 11 linent))
          tagang  (angle linest linend)
          cnt     1
          tcirc   (* dwgscal 4.2))
    (initget 7)
    (if (setq tagcnt (getint "\nSpecify Number of Tags: "))
      (progn
        (while (and (<= cnt tagcnt)
            (/= (setq tagtxt
                   (getstring (strcat "\nType Text for Tag ["
                              (rtos cnt 2 0)
                              "]: ")))
                ""))
          (setq tagtxt (strcase tagtxt))
          (setvar "clayer" "TEXT")
          (setq tcirccent (polar linend tagang (* (- (* cnt 2) 1) tcirc)))
          (setvar "osmode" 0)
          (command "_circle" tcirccent tcirc)
          (entmake
        (list '(0 . "TEXT")
              '(8 . "TEXT")
              (cons 10 tcirccent)
              (cons 40 (* dwgscal 2.5))
              (cons 1 tagtxt)
              '(50 . 0.0)
              '(7 . "STANDARD")
              '(71 . 0)
              '(72 . 1)
              '(73 . 2)
              (cons 11 tcirccent)))
          (setq cnt    (1+ cnt)
            tagtxt "")))))))
 (*error* "")
 (princ))

(defun c:tagger (/ *error* vLst oVars ans pTxt sTxt cnt iPt drTag bubTag drTagLst bubTagLst)
 (defun *error* (msg)
   (if oVars
     (mapcar 'setvar vLst oVars))
   (if (eq "" msg)
     (princ "\n<< Function Complete >>")
     (princ (strcat "Error: " (strcase msg))))
   (princ))
 (setq vLst (list "OSMODE" "CLAYER" "ATTREQ" "BLIPMODE")
   oVars (mapcar 'getvar vLst))
 (mapcar 'makelay '("A-DOOR-IDEN" "S-GRID-IDEN") '("5" "4"))
 (if (and (tblsearch "BLOCK" "Tagdoor1") (tblsearch "BLOCK" "Grdbub01"))
   (progn
 (if (not TG:oans) (setq TG:oans "Door"))
 (initget "Door Bubble")
 (setq ans (getkword (strcat "\nSpecify Tag Type [Door/Bubble] <" TG:oans ">: ")))
 (if (not ans) (setq ans TG:oans) (setq TG:oans ans))
 (if (and (setq pTxt (getstring t "\nSpecify Prefix Text <Enter for no Prefix>:  "))
      (not (initget 5))
      (setq sNum (getint "\nSpecify Starting Number: ")
        sTxt (getstring t "\nSpecify Suffix Text <Enter for no Suffix>:  ")))
   (progn
     (setq cnt 0)
     (mapcar 'setvar vLst (list 0 "0" 0 0))
     (while (setq iPt (getpoint "\nSelect Point for Symbol > "))
   (cond ((= ans "Door")
          (setvar "clayer" "A-DOOR-IDEN")
          (command "-insert" "Tagdoor1" iPt "" "" "")
          (setq drTag (entnext (entlast)))
          (while (/= "SEQEND" (cdadr (setq drTagLst (entget drTag))))
        (if (= "DR1NUM" (cdr (assoc 2 drTagLst)))
          (entmod (subst (cons 1 (strcat pTxt (rtos (+ sNum cnt) 2 0) sTxt))
                 (assoc 1 drTagLst) drTagLst)))
        (setq drTag (entnext drTag)))
          (command "_regenall"))
         ((= ans "Bubble")
          (setvar "clayer" "S-GRID-IDEN")
          (command "-insert" "Grdbub01" iPt "" "" "")
          (setq bubTag (entnext (entlast)))
          (while (/= "SEQEND" (cdadr (setq bubTagLst (entget bubTag))))
        (if (= "GRIDNUM" (cdr (assoc 2 bubTagLst)))
          (entmod (subst (cons 1 (strcat pTxt (rtos (+ sNum cnt) 2 0) sTxt))
                 (assoc 1 bubTagLst) bubTagLst)))
        (setq bubTag (entnext bubTag)))
          (command "_regenall")))
   (setq cnt (1+ cnt))))))           
   (princ "\n<!> One or More Blocks not Found <!>"))
 (*error* "")
 (princ))
(defun makelay (x y)
 (if    (not (tblsearch "LAYER" x))
   (command "-layer" "M" x "C" y x "")))