[编程交流] 插入多个块

(defun c:Test (/ *error* Deconstruct_String right left con1 con2 xl ok o st l lst a b c d f fp bn p go vl name ch)
 ;;                    ;;
 ;;    Author : Tharwat Al Shoufi    ;;
 ;;                    ;;
 (or doc (setq doc (vla-get-activedocument (vlax-get-acad-object))))
 (defun *error* (u)
   (if ch
     (setvar 'CMDECHO ch)
   )
   (princ "\n*Cancel*")
 )
 (defun Deconstruct_String (st delimiter / p l)
   (while (setq p (vl-string-search delimiter st 0))
     (setq l  (cons (substr st 1 p) l)
           st (substr st (+ p 2) (strlen st))
     )
   )
   (if st
     (setq l (cons st l))
   )
   (setq l (reverse l))
 )
 (if (setq xl (getfiled "Select the required Excel file :" (getvar 'DWGPREFIX) "csv" 16))
   (progn (setq ok t
                ch (getvar 'CMDECHO)
                o  (open xl "r")
          )
          (setvar 'CMDECHO 0)
          (while (setq st (read-line o))
            (setq l   (cons (setq st (Deconstruct_String st ",")) l)
                  lst (cons (strcase (car st)) lst)
            )
          )
          (close o)
   )
   (setq ok nil)
 )
 
 (if (and ok
          (/= (setq bn (getstring t "\n Specify Attributed Block name to insert :")) "")
          (if (member (setq bn (strcase bn)) lst)
            t
            (progn (alert "Block name is not included in the Excel file <!>") nil)
          )
          (if (not (tblsearch "BLOCK" bn))
            (if (setq fp (findfile (strcat bn ".dwg")))
              (progn (command "_.-insert" fp nil) t)
              (progn (alert "Block Name is not found in Support Folder <!>") nil)
            )
            t
          )
     )
   (progn (setvar 'CMDECHO ch)
     (vla-StartUndoMark doc)
          (while (setq p (getpoint "\n Specify insertion point :"))
            (setq vl (vla-insertblock (vla-get-block (vla-get-activelayout doc)) (vlax-3d-point p) bn 1.0 1.0 1.0 0.))
            (foreach x (vlax-invoke vl 'getattributes)
              (foreach tg l
                (if (and (eq (car tg) (strcase bn)) (eq (strcase (vla-get-tagstring x)) (cadr tg)))
                  (vla-put-textstring x (caddr tg))
                )
              )
            )
          )
     (vla-EndUndoMark doc)
   )
 )
 (princ)
)
(vl-load-com)