[编程交流] 块的插入

(defun describe ()
;;;Do the mapcar function for each layer in the drawing.
 (vlax-for layer
       (vla-get-layers
         (vla-get-activedocument
       (vlax-get-acad-object)
       )
         )
;;;if the current layer being checked matches a predetermined name, add the needed description.
   (mapcar
     (function
   (lambda (layname description)
     (if (= (strcase (vla-get-name layer)) (strcase layname))
       (vla-put-description layer description)
       ()
       )
     )
   )
     '("A-------O2-" ) ; This is your list of layers needing a description.
     '("arrow"); This is the descriptions for each layer.  Make sure the order is EXACTLY the same as in the layer list.
     )
   )
 (princ); Silent exit.
 )
   (defun layercreation ()
       (if  (tblsearch "LAYER" "A-------O2-")
(command "_layer" "s" "A-------O2-" "")
           (command "-layer" "M" "A-------O2-" "C" "red" "A-------O2-" "")
           ) ; end if
          );en defun
(defun c:test ( / sl oldlay)
(setq path (strcat "K:\\CAD\\Block\\arrow"))
(cond
 ((path)
  (
 (setq oldlay (getvar "clayer"))
 (setq sl nil)
 (setq sl (dos_dwgpreview "Välj Block" "K:\\CAD\\Block\\arrow"))
 (prompt "\nChoose insertion point...")
 (if sl
   (progn
     (layercreation)
     (describe)
     (setvar "clayer" "A-------O2-") 
     (command "-insert" sl pause "1" "1" "0")
   (setvar "clayer" oldlay)
);progn
   );if
 ))(t (exit)))
 )

;author        :        jammie
;version         :        0.0
;date                :        2009-02-12
;posted  : cadtutor.net
;thread : http://www.cadtutor.net/forum/newreply.php?do=newreply&noquote=1&p=212231
(defun c:test (/ laycode lay_name fname oldlay path test)
;laycodes is a list of a drawing paths and layer names. Each list within laycodes is a pair  (<path> <layer name>)
;The first element is the block path. The second element is the layer name associated with the block
;Any blocks found to come from a particular path will be inserted on a preset layer
;
;eg
;("K:\\CAD\\Block\\arrow"         "A-------O2-")
;A block inserted from "K:\\CAD\\Block\\arrow" will be inserted on layer "A-------O2-"
;
;Note the path is case sensitive
 
(setq laycodes '(
                 ("K:\\CAD\\Block\\arrow"         "A-------O2-");<-edit this list as required
                 ("K:\\CAD\\Block\\cars"         "A-------O1-")
                                          )
      )
         (if
  ;select the drawing to insert
  (and (setq fname (dos_dwgpreview  "Välj Block" "K:\\CAD\\Block\"  ".dwg")) (/= fname ""))
  ;if a file has been selected
  (progn
    ;store the current layer
    (setq oldlay   (getvar "clayer"))
    ;retrieve the path
    (setq path     (vl-filename-directory fname))
    (if
        ;check the path against the laycodes
              (setq test (assoc path laycodes))
              ;if a match is found
      
              (or
          ;test if the preset layer exists
          (tblsearch "layer" (setq lay_name (cadr test)))
           ;if it does not add it
          (command "layer" "m" lay_name ""))
      ;if the file does not match the predefined
      
            (alert
              (strcat "\n<" (vl-filename-base fname) "> is not from a preset directory"
                      " \nValid directories are :"
                      (apply 'strcat (mapcar '(lambda (x) (strcat "\n\t" (car x))) laycodes))
                      "\nBlock <" (vl-filename-base fname) "> will be inserted on layer <" (getvar "clayer")">")))
      
    
    (and lay_name (setvar "clayer" lay_name))
    (command "-insert" fname pause "1" "1" "0")
    
    (and lay_name  (setvar "clayer" oldlay))
    )
  (alert "\nNo file selected")
  )
 (princ)
 )

(defun c:test (/ laycode lay_name fname oldlay path test)
;laycodes is a list of a drawing paths, layer names and preset colors.
;Each list within laycodes contains 3 elements  (<path> <layer name> <layer color>)
;The first element is the block path.
;The second element is the layer name associated with the block
;The third item in a list references the layer color
 
;Any blocks found to come from a particular path will be inserted on a preset layer
;If the layer does not exist it will be created and a layer color assigned to ir
;
;eg
;("K:\\CAD\\Block\\arrow"         "A-------O2-"   1)
;A block inserted from "K:\\CAD\\Block\\arrow" will be inserted on layer "A-------O2-" which has a color 1
;
;Note the path is case sensitive
 
(setq laycodes '(
                 ("K:\\CAD\\Block\\arrow"         "A-------O2-"  1);<-edit this list as required
                 ("K:\\CAD\\Block\\cars"         "A-------O1-"  140)
                                          )
      )
         (if
  ;select the drawing to insert
  (and (setq fname (dos_dwgpreview  "Välj Block" "K:\\CAD\\Block\"  ".dwg")) (/= fname ""))
  ;if a file has been selected
  (progn
    ;store the current layer
    (setq oldlay   (getvar "clayer"))
    ;retrieve the path
    (setq path     (vl-filename-directory fname))
    (if
        ;check the path against the laycodes
              (setq test (assoc path laycodes))
              ;if a match is found
      
              (or
          ;test if the preset layer exists
          (tblsearch "layer" (setq lay_name (cadr test)))
           ;if it does not add it
          (and
            (command "layer" "m" lay_name "")
            (command "layer" "c" (caddr test) lay_name "" "" );<-line added to change the layer to the required color
            )
          )
      ;if the file does not match the predefined
      
            (alert
              (strcat "\n<" (vl-filename-base fname) "> is not from a preset directory"
                      " \nValid directories are :"
                      (apply 'strcat (mapcar '(lambda (x) (strcat "\n\t" (car x))) laycodes))
                      "\nBlock <" (vl-filename-base fname) "> will be inserted on layer <" (getvar "clayer")">")))
      
    
    (and lay_name (setvar "clayer" lay_name))
    (command "-insert" fname pause "1" "1" "0")
    
    (and lay_name  (setvar "clayer" oldlay))
    )
  (alert "\nNo file selected")
  )
 (princ)
 )

(command "layer" "c" (caddr test) lay_name "" )

 (command "layer" "m" lay_name "c" (caddr test) lay_name "")