[编程交流] 修改块

;;---------------=={ Apply to Block Objects }==---------------;;
;;                                                            ;;
;;  Applies a supplied function to all objects in a block     ;;
;;  definition.                                               ;;
;;------------------------------------------------------------;;
;;  Author: Lee Mac, Copyright © 2011 - www.lee-mac.com       ;;
;;------------------------------------------------------------;;
;;  Arguments:                                                ;;
;;  _acblocks  - block collection in which block resides      ;;
;;  _blockname - name of block to apply function              ;;
;;  _function  - function to apply to all objects in block    ;;
;;------------------------------------------------------------;;
;;  Returns: List of results of evaluating function, else nil ;;
;;------------------------------------------------------------;;
(defun LM:ApplytoBlockObjects ( _acblocks _blockname _function / result )
 (
   (lambda ( _function / def )  
     (if
       (not
         (vl-catch-all-error-p
           (setq def
             (vl-catch-all-apply 'vla-item (list _acblocks  _blockname))
           )
         )
       )
       (vlax-for obj def (setq result (cons (_function obj) result)))
     )
   )
   (eval _function)
 )
 (reverse result)
)
;; Test Function to Move all Objects in a Block to Layer "0"
(defun c:test ( / acdoc acblk ss l ) (vl-load-com)
 (setq acdoc (vla-get-activedocument (vlax-get-acad-object))
       acblk (vla-get-blocks acdoc)
 )
 (if (setq ss (ssget "_+.:E:S" '((0 . "INSERT"))))
   (progn    
     (LM:ApplytoBlockObjects acblk (cdr (assoc 2 (setq l (entget (ssname ss 0)))))
       (function
         (lambda ( obj ) (vla-put-Layer obj "0"))
       )
     )
   )
 )
 (princ)
)