[编程交流] 块和层

; (setq *LinkLyrBlk* nil)
(defun C:LinkLayerBlock ( / SymNms Lyrs Blks Lyr Blk itm )
 
 (defun SymNms ( tbl / d L )
   (while (setq d (tblnext tbl (not d))) (setq L (cons (cdr (assoc 2 d)) L)) )
   (acad_strlsort L)
 ); defun SymNms
 (if
   (and 
     (setq Lyrs (SymNms "LAYER"))
     (setq Blks (SymNms "BLOCK"))
     (setq Blks (vl-remove-if '(lambda (x) (wcmatch x "`*U*,_*,`*T*")) Blks))
     (setq Lyr (car (LM:listbox "Select Layer" Lyrs 0)))
     (setq Blk (car (LM:listbox (strcat "Select Block to link with " Lyr) Blks 0)))
   )
   (progn 
     (foreach rtr (cdar (vlr-reactors :vlr-AcDb-reactor)) (if (= "LinkLyrBlk" (vlr-data rtr)) (vlr-remove rtr)))
     (vlax-for o (vla-get-Block (vla-get-ActiveLayout (vla-get-ActiveDocument (vlax-get-acad-object))))
       (and 
         (vlax-write-enabled-p o)
         (eq "AcDbBlockReference" (vla-get-ObjectName o))
         (eq Blk (vla-get-EffectiveName o))
         (vla-put-Layer o Lyr)
       ); and 
     ); vlax-for
     (cond
       ( (setq itm (assoc Lyr *LinkLyrBlk*))
         (setq *LinkLyrBlk* (mapcar '(lambda (x) (vl-remove-if '(lambda (b) (eq b Blk)) (cdr x))) *LinkLyrBlk*)); Remove duplicate blocks
         (setq *LinkLyrBlk* (subst (append itm (list Blk)) itm *LinkLyrBlk*))
       )
       ( (setq *LinkLyrBlk* (cons (list Lyr Blk) *LinkLyrBlk*)) )
     ); cond
     (vlr-AcDb-reactor "LinkLyrBlk" 
       '((:vlr-objectAppended . LinkLyrBlk:callback)
         (:vlr-objectReAppended . LinkLyrBlk:callback)
         (:vlr-objectModified . LinkLyrBlk:callback)
       )
     ); vlr-AcDb-reactor
   ); progn
 ); if
 (princ)
); defun C:LinkLayerBlock
(defun LinkLyrBlk:callback (rtr arg / e o nm )
 (and 
   *LinkLyrBlk*
   (eq 'ENAME (type (setq e (cadr arg))))
   (= "INSERT" (cdr (assoc 0 (entget e))))
   (setq o (vlax-ename->vla-object e))
   (vlax-write-enabled-p o)
   (eq "AcDbBlockReference" (vla-get-ObjectName o))
   (setq nm (vla-get-EffectiveName o))
   (vl-some 
     '(lambda (a)
       (vl-some
         '(lambda (b)
           (if (eq b nm) (progn (vla-put-Layer o (car a)) T))
         ); lambda b
         (cdr a)
       ); vl-some
     ); lambda a
     *LinkLyrBlk*
   ); vl-some
 ); and
); defun LinkLyrBlk:callback
;; List Box  -  Lee Mac
;; Displays a DCL list box allowing the user to make a selection from the supplied data.
;; msg - [str] Dialog label
;; lst - [lst] List of strings to display
;; bit - [int] 1=allow multiple; 2=return indexes
;; Returns: [lst] List of selected items/indexes, else nil
(defun LM:listbox ( msg lst bit / dch des tmp rtn )
 (cond
   (   (not
     (and
       (setq tmp (vl-filename-mktemp nil nil ".dcl"))
       (setq des (open tmp "w"))
       (write-line
         (strcat "listbox:dialog{label="" msg "";spacer;:list_box{key="list";multiple_select="
           (if (= 1 (logand 1 bit)) "true" "false") ";width=50;height=15;}spacer;ok_cancel;}"
         )
         des
       )
       (not (close des))
       (< 0 (setq dch (load_dialog tmp)))
       (new_dialog "listbox" dch)
     )
   )
   (prompt "\nError Loading List Box Dialog.")
   )
   (   t     
     (start_list "list")
     (foreach itm lst (add_list itm))
     (end_list)
     (setq rtn (set_tile "list" "0"))
     (action_tile "list" "(setq rtn $value)")
     (setq rtn
       (if (= 1 (start_dialog))
         (if (= 2 (logand 2 bit))
           (read (strcat "(" rtn ")"))
           (mapcar '(lambda ( x ) (nth x lst)) (read (strcat "(" rtn ")")))
         )
       )
     )
   )
 )
 (if (< 0 dch)
   (unload_dialog dch)
 )
 (if (and tmp (setq tmp (findfile tmp)))
   (vl-file-delete tmp)
 )
 rtn
)