[编程交流] 寻找Lisp例程

;;published by kpblc
;;http://www.arcada.com.ua/forum/viewtopic.php?t=526
(defun c:normblocks (/ adoc answer lays lock lay *error* ans0 atype cnt) 
(defun *error* (msg)(princ msg)
  (if lock (foreach x lock (vla-put-lock x :vlax-true)))(vl-cmdf "_.Redraw")) 
 (vl-load-com)(setq cnt 0) 
 (setq adoc (vla-get-activedocument (vlax-get-acad-object))) 
 (setq lays (vla-get-layers adoc)) 
 (vla-startundomark adoc) 
 (initget "LType LWeight Color All _ T W C A") 
 (if (null (setq answer 
     (getkword "\nIn blocks to lead to norm [LType/LWeight/Color/All] <All> : ")))
   (setq answer "A")) ;_ end of if
 (initget "byLayer byBlock")
 (setq atype (getkword "\nSet contents inside the block to [byLayer/byBlock] <byBlock>:"))
 (initget "Yes No")
 (setq ans0 (getkword "\nChange entities layer's to 0? [Yes/No] <No>:"))
 (vlax-for item (vla-get-blocks adoc) 
   (if   (not (wcmatch (strcase (vla-get-name item) t) "*_space*"))
     (progn
     (setq cnt (1+ cnt))
     (grtext -1 (strcat "Modyfied " (vla-get-name item)))
  (vlax-for   sub_item (vla-item (vla-get-blocks adoc) (vla-get-name item)) 
  (setq lay (vla-item lays (vla-get-layer sub_item))) 
  (if (= (vla-get-lock lay) :vlax-true) 
  (progn (vla-put-lock lay :vlax-false)(setq lock (cons lay lock))))  
  (if (= ans0 "Yes")(vla-put-Layer sub_item "0"))
  (cond 
    ((= answer "W") 
     (vla-put-LineWeight sub_item (if (= atype "byLayer") acLnWtByLayer aclnwtbyblock))
     ) 
    ((= answer "T") 
     (vla-put-linetype sub_item (if (= atype "byLayer") "ByLayer" "ByBlock"))
     ) 
    ((= answer "C") 
     (vla-put-color sub_item (if (= atype "byLayer") acByLayer acByBlock))
     ) 
    (t 
     (vla-put-LineWeight sub_item (if (= atype "byLayer") acLnWtByLayer aclnwtbyblock))
     (vla-put-linetype sub_item (if (= atype "byLayer") "ByLayer" "ByBlock"))      
     (vla-put-color sub_item (if (= atype "byLayer") acByLayer acByBlock))
     ) 
    ) ;_ end of cond 
  ) ;_ end of vlax-for
  )
     ) ;_ end of if 
   ) ;_ end of vlax-for 
 (if lock (foreach x lock (vla-put-lock x :vlax-true))) 
 (vla-regen adoc acallviewports) 
 (vla-endundomark adoc)(vl-cmdf "_.Redraw")
 (princ (strcat  "\nModyfied " (itoa cnt) " blocks"))
 (princ) 
 ) ;_ end of defun