[编程交流] Lisp合并和更新

;; cca.lsp
(defun C:CCA  (/ attent atttag attval elist en head pt ss tail)
 (setq osm (getvar "osmode"))
 (setvar "osmode" 513)
 (setq        pt (getpoint
     "\n   ***   Specify point on the source block   ***"))
 (setq ss (ssget pt (list (cons 0 "INSERT") (cons 66 1))))
 (sssetfirst nil ss)
 (if ss
   (progn
     (setq en (ssname ss 0))
     (setq elist (entget en))
     (while (=        (cdr
          (assoc 0
                 (setq elist (entget (entnext
                                       (setq attent (cdr (assoc -1 elist))))))))
        "ATTRIB")
(setq atttag (cdr (assoc 2 elist)))
(setq attval (cdr (assoc 1 elist)))
(cond ((eq "NODE_ID" atttag)
       (setq head (cdr (assoc 1 elist))))
      ((eq "DEVICE-TYPE_ID" atttag)
       (setq tail (cdr (assoc 1 elist))))
      (T nil)
      )
(ssdel en ss)
)
     )
   (princ "\n   0 blocks selected")
   )
 (sssetfirst nil nil)
 (setq ss nil)
 (prompt
   "\n   ***   Select all target blocks you need to update   ***")
 (setq ss (ssget (list (cons 0 "INSERT") (cons 66 1))))
 (sssetfirst nil ss)
 (if (and head tail ss)
   (progn
     (while
(setq en (ssname ss 0))
 (setq elist (entget en))
 (while        (= (cdr
             (assoc 0
                    (setq elist        (entget        (entnext
                                          (setq attent (cdr (assoc -1 elist))))))))
           "ATTRIB")
   (setq atttag (cdr (assoc 2 elist)))
   (if (eq "ACTIVE" atttag)
     (progn
       (entmod (subst (cons 1 (strcat head "-" tail))
                      (assoc 1 elist)
                      elist))
       (entupd en)
       )
     )
   (ssdel en ss)
   )
 )
     (sssetfirst nil nil)
     )
   (princ "\n   0 blocks selected")
   )
 (setvar "osmode" osm)
 (princ)
 )
(princ "   ***   Start command wit CCA   ***")
(princ)

(defun c:tagupd (/ bEnt aEnt aEntLst aNode aType nAtt ss entLst dAtt dAttLst)
 (vl-load-com)
 (if (and (setq bEnt (car (entsel "\nSelect Block to Retrieve Tag Values >  ")))
      (= "INSERT" (cdr (assoc 0 (entget bEnt))))
      (= 1 (cdr (assoc 66 (entget bEnt)))))
   (progn
     (setq aEnt (entnext bEnt))
     (while (not (eq "SEQEND" (cdr (assoc 0 (setq aEntLst (entget aEnt))))))
   (cond ((= "NODE_ID" (cdr (assoc 2 aEntLst)))
          (setq aNode (cdr (assoc 1 aEntLst))))
         ((= "DEVICE-TYPE_ID" (cdr (assoc 2 aEntLst)))
          (setq aType (cdr (assoc 1 aEntLst)))))
   (setq aEnt (entnext aEnt)))
     (setq nAtt (strcat aNode (chr 45) aType))
     (if (setq ss (ssget (list (cons 0 "INSERT") (cons 66 1)
   (if (getvar "CTAB") (cons 410 (getvar "CTAB")) (cons 67 (- 1 (getvar "TILEMODE")))))))
   (progn
     (setq entLst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
     (foreach ent entLst
       (setq dAtt (entnext ent))
       (while (not (eq "SEQEND" (cdr (assoc 0 (setq dAttLst (entget dAtt))))))
         (if (= "ACTIVE" (cdr (assoc 2 dAttLst)))
       (setq dAttLst (subst (cons 1 nAtt) (assoc 1 dAttLst) dAttLst))
       (entmod dAttLst))
         (setq dAtt (entnext dAtt)))))
   (princ "\n<!> No Destination Blocks Selected <!>")))
   (princ "\n<!> No Attributed Block Selected <!>"))
 (command "_regenall")
 (princ))

(defun c:tagupd (/ bEnt aEnt aEntLst aNode aType nAtt ss entLst dAtt dAttLst)
 (vl-load-com)
 (if (and (setq bEnt (car (entsel "\nSelect Block to Retrieve Tag Values >  ")))
      (= "INSERT" (cdr (assoc 0 (entget bEnt))))
      (= 1 (cdr (assoc 66 (entget bEnt)))))
   (progn
     (setq aEnt (entnext bEnt))
     (while (not (eq "SEQEND" (cdr (assoc 0 (setq aEntLst (entget aEnt))))))
   (cond ((= "NODE_ID" (cdr (assoc 2 aEntLst)))
          (setq aNode (cdr (assoc 1 aEntLst))))
         ((= "DEVICE-TYPE_ID" (cdr (assoc 2 aEntLst)))
          (setq aType (cdr (assoc 1 aEntLst)))))
   (setq aEnt (entnext aEnt)))
     (setq nAtt (strcat aNode (chr 45) aType))
     (if (setq ss (ssget (list (cons 0 "INSERT") (cons 66 1)
   (if (getvar "CTAB") (cons 410 (getvar "CTAB")) (cons 67 (- 1 (getvar "TILEMODE")))))))
   (progn
     (setq entLst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
     (foreach ent entLst
       (setq dAtt (entnext ent))
       (while (not (eq "SEQEND" (cdr (assoc 0 (setq dAttLst (entget dAtt))))))
         (if (= "ACTIVE" (cdr (assoc 2 dAttLst)))
       (progn
       (setq dAttLst (subst (cons 1 nAtt) (assoc 1 dAttLst) dAttLst))
       (entmod dAttLst)))
         (setq dAtt (entnext dAtt)))))
   (princ "\n<!> No Destination Blocks Selected <!>")))
   (princ "\n<!> No Attributed Block Selected <!>"))
 (command "_regenall")
 (princ))