[编程交流] 李'；s层控制器

;;; ------------------------------------------------------------------------
;;;        XRefsToLayers.lsp v1.0
;;;
;;;        Copyright© 04.27.10
;;;        Alan J. Thompson (alanjt)
;;;
;;;        Contact: alanjt @ TheSwamp.org, CADTutor.net
;;;
;;;        Permission to use, copy, modify, and distribute this software
;;;        for any purpose and without fee is hereby granted, provided
;;;        that the above copyright notice appears in all copies and
;;;        that both that copyright notice and the limited warranty and
;;;        restricted rights notice below appear in all supporting
;;;        documentation.
;;;
;;;        The following program(s) are provided "as is" and with all faults.
;;;        Alan J. Thompson DOES NOT warrant that the operation of the program(s)
;;;        will be uninterrupted and/or error free.
;;;
;;;        Allows user to moved all XRefs to layer, based on XRef name with
;;;        prefix of "G-XREF_".
;;;        User also has option to lock created XRef layers.
;;;
;;;        Revision History:
;;;
;;; ------------------------------------------------------------------------
(defun c:XR2L (/) (c:XRefsToLayers))
(defun c:XRefsToLayers (/ *error* Prefix4Layer xrefLst ss flag lock layLst lst)
 ;; Prefix4Layer (if no prefix wanted, set as "")
 (setq Prefix4Layer "G-XREF_")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SUBROUTINES ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; error handler
 (defun *error* (msg)
   (and flag *AcadDoc* (vla-EndUndoMark *AcadDoc*))
   (and msg
        (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*QUIT*"))
        (princ (strcat "\nError: " msg))
   )
 )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;; MAIN ROUTINE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (vl-load-com)
 (if (eq ""
         (setq xrefLst
                ((lambda (s)
                   (vlax-for x (vla-get-blocks
                                 (cond (*AcadDoc*)
                                       ((setq *AcadDoc* (vla-get-ActiveDocument (vlax-get-acad-object))))
                                 )
                               )
                     (and (eq (vla-get-isXRef x) :vlax-true) (not (wcmatch (vla-get-name x) "*TBLOCK*")) (setq s (strcat s (vla-get-name x) ",")))
                   )
                   s
                 )
                  ""
                )
         )
     )
   (alert "Zero XRefs in drawing.")
   (if (setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 xrefLst))))
     ((lambda (pre layers)
        (initget 0 "Yes No")
        (setq lock "No")
        (setq flag (not (vla-StartUndoMark *AcadDoc*)))
        (vlax-for o (setq ss (vla-get-ActiveSelectionSet *AcadDoc*))
          ((lambda (layer)
             (or (vl-position layer layLst) (setq layLst (cons layer layLst)))
             (setq lst ((lambda (lst)
                          ((lambda (ass)
                             (if ass
                               (subst (cons (car ass) (1+ (cdr ass))) ass lst)
                               (cons (cons layer 1) lst)
                             )
                           )
                            (assoc layer lst)
                          )
                        )
                         lst
                       )
             )
             (or (eq (vla-get-layer o) (strcat pre (vla-get-name o)))
                 (if (vl-catch-all-error-p
                       (vl-catch-all-apply
                         (function vla-put-layer)
                         (list o layer)
                       )
                     )
                   ((lambda (item)
                      (vla-put-lock item :vlax-false)
                      (vla-put-layer o layer)
                      (vla-put-lock item :vlax-true)
                    )
                     (vla-item layers (vla-get-layer o))
                   )
                 )
             )
           )
            (if (vl-position (strcat pre (vla-get-name o)) layLst)
              (strcat pre (vla-get-name o))
              (vla-get-name (vla-add layers (strcase (strcat pre (vla-get-name o)))))
            )
          )
        )
        (vla-delete ss)
        (and
          layLst
          (or (eq lock "No")
              (mapcar (function (lambda (l) (vla-put-lock (vla-item layers l) :vlax-true))) layLst)
          )
;;;           lst
;;;           (foreach i (vl-sort lst (function (lambda (a b) (< (car a) (car b)))))
;;;             (princ (strcat "\n" (itoa (cdr i)) " XRef(s) on layer: "" (car i) """))
;;;           )
          (setq lst ((lambda (lst str)
                       (if lst
                         (progn
                           (foreach i (vl-sort lst
                                               (function (lambda (a b)
                                                           (< (car a) (car b))
                                                         )
                                               )
                                      )
                             (setq str (strcat str
                                               "\n"
                                               (itoa (cdr i))
                                               " XRef(s) on layer: ""
                                               (car i)
                                               """
                                       )
                             )
                           )
                           str
                         )
                       )
                     )
                      lst
                      ""
                    )
          )
          (alert lst)
        )
      )
       Prefix4Layer
       (vla-get-Layers *AcadDoc*)
     )
   )
 )
 (*error* nil)
 (princ)
)
(c:XR2L)