[编程交流] 批量块插入。

;;;******************************************************************************
;;;The hard parts of this code written by Lee Mac and posted on CADTutor.        
;;;Duct tape, baling twine and nails sticking out at odd angles                  
;;; holding that code together added by Glen Smith.                              
;;;                                                                              
;;;  [url]http://www.cadtutor.net/forum/showthread.php?t=38230[/url]                        
;;;                                                                              
;;;Copyright August - September 2009                                             
;;;                                                                              
;;;  The LISP takes an input file, searches by block handle for the block in     
;;;   the drawing, zooms in on the block and inserts three blocks at the same    
;;;   insertion point. The searched block list is then brought to the front of   
;;;   the drawing.                                                               
;;;                                                                              
;;;                                                                              
;;;******************************************************************************
;;;                                                                              
;;;          Additional files required in the working directory:                 
;;;                                                                              
;;; KEY_SCHED.dwg - The key schedule block.                                      
;;; KEY_SCHED_WIPEOUT.dwg - A wipeout block so the KEY_SCHED attributes can be read.
;;; KEY_CHG_*.DWG - Multiple different colored blocks to visually distinguish    
;;;                  between the key groups that have been assigned.             
;;; KEY_MG_*.DWG - Multiple different colored blocks to visually distinguish     
;;;                  between the different master groups that have been assigned.
;;;                                                                              
;;; NOTE: The insertion point/orgin for all of these blocks is assumed to be in  
;;;       the lower left corner such that they 'stack' when inserted at the same 
;;;       point.                                                                 
;;;                                                                              
;;;******************************************************************************
;;;                                                                              
;;; USEAGE:                                                                      
;;; Insert KEY_SCHED.dwg block at all door locations to be color coded for keys. 
;;; Assign values to the 5 attributes in the KEY_SCHED block.                    
;;; Export the attributes of the KEY_SCHED block, and open in a spreadsheeet.    
;;; In the first column the block handle must remain, put the filename for the   
;;; key change code in the second column, the filename for the master group color
;;; code in the third column. The filename for the wipeout should be in the fourth
;;; column. The remaining columns and the header line should be deleted.         
;;; Save the file.                                                               
;;;                                                                              
;;; Save the drawing!                                                            
;;;                                                                              
;;; Load keysched.lsp by typing appload at the command line and selecting it.    
;;; Type keysched at the command line, select the input file which was previously
;;; created. The LSIP will run and there will be a lag time after it appears to  
;;; complete and the time that control is returned to you.  Color coding will be 
;;; placed on the KEY_COLORS layer, and the wipeout will be placed on the wipeout
;;; layer. These layers will be created if they do not exist.                    
;;;                                                                              
;;; It is important to remember that this routine will not delete previuos color 
;;; coding. Either manually change the coding or delete them all and recode the  
;;; entire drawing.                                                              
;;;                                                                              
;;;                                                                              
;;;******************************************************************************
;;;                                                                              
(defun c:KEYSCHED
      (/ file nl inslst Minp Maxp pts elst ipt xScale yScale rot entity kclst mglst wipelst count oldlayer )
  (vl-load-com)
  (defun StrBrk (str delim / pos lst)
     (while (setq pos (vl-string-position delim str))
        (setq lst (cons (substr str 1 pos) lst)
              str (substr str (+ pos 2))
        )
     )
     (reverse (cons str lst))
  )
  (defun RTD (a)                       ;radians to degrees function
     (/ (* a 180.0) PI)                ;takes angle in radians, returns angle in degrees
  )                                    ;end function RTD
  (setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
  (vla-startUndoMark doc)
  (command "Layer" "M" "KEY_COLORS" "")
  (command "Layer" "M" "WIPEOUT" "")
  (setq oldlayer (getvar "CLAYER"))
  (if (setq file (getfiled "Select Text File" (if *load *load "") "txt" 0))
        ;the file selected is stored in the GLOBAL variable *load and so defaults to the same filename in subsequent runs.
     (progn
        (setq *load file file  (open file "r"))
        (while (setq nl (read-line file))
           (setq entity (StrBrk nl 9))             ;entity should be a list of the entries on the nl
    (setq inslst (cons (nth 0 entity) inslst))      ;inslst gets the first entry  from the entity list
           (setq kclst (cons (nth 1 entity) kclst))      ;kclst gets the second entry from the entity list
           (setq mglst (cons (nth 2 entity) mglst))      ;mglst gets the third entry from the entity list
           (setq wipelst (cons (nth 3 entity) wipelst))  ;wipelst gets the fourth entry from the entity list
        )
        (close file)
        (if (setq elst
                    (vl-remove-if
                       'null
                       (mapcar 'handent
                               (mapcar
                                  (function (lambda (x) (substr x 2)))
                                  (reverse inslst)
                               )
                       )
                    )
            )
            (progn
               ;put the lists back into the right order so all four lists match.
               (setq kclst (reverse kclst))
               (setq mglst (reverse mglst))
               (setq wipelst (reverse wipelst))
               (setq count 0)
        (foreach Obj (mapcar 'vlax-ename->vla-object elst)
                  (progn
                     (vla-getBoundingBox Obj 'Minp 'Maxp)
       (setq pts (mapcar 'vlax-safearray->list (list Minp Maxp)))
       (vla-ZoomCenter
          (vlax-get-acad-object)
          (vlax-3D-point
             (polar (car pts)
                    (apply 'angle pts)
                    (/ (apply 'distance pts) 2.)
             )
          )
          400.
                     )
                  )
    (setq ipt
            (vlax-safearray->list
               (vlax-variant-value
                  (vla-get-InsertionPoint obj)
               )
            )
    )
    (setq rot (RTD (vla-get-rotation obj)))
    (setq xScale (vla-get-xscalefactor obj))
    (setq yScale (vla-get-yscalefactor obj))
    (setvar "CLAYER" "WIPEOUT")
                  (if (nth count wipelst)
       (command "-insert" (nth count wipelst) ipt xScale yScale rot)
                  )
                  (setvar "CLAYER" "KEY_COLORS")
                  (if (nth count kclst)
       (command "-insert" (nth count kclst) ipt xScale yScale rot)
                  )
                  (if (nth count mglst)
                     (command "-insert" (nth count mglst) ipt xScale yScale rot)
                  )
    (setq count(1+ count))
               )
            )
         )
         ;bring the key block and attributes to the front so they can be read.
   (setq ent (car elst))
  (progn
     (setq ss (ssget "X"
                     (list (cons 8 (cdr (assoc 8 (entget ent)))))
              )
     )
  (command "_draworder" ss "" "_Front")
  )
      )
      (princ "\n<< No File Selected >>")
  )
  (setvar "CLAYER" oldlayer)
  (vla-EndUndoMark doc)
  (princ)
)