[编程交流] LISP用于快速处理图层

-layer n layer1 c layer1 45
n layer211 c layer211 30 Lt dashed
textstyle standard

(defun MakeLayer ( name colour linetype lineweight willplot bitflag description )
 ;; © Lee Mac 2010
 (or (tblsearch "LAYER" name)
   (entmake
     (append
       (list
         (cons 0 "LAYER")
         (cons 100 "AcDbSymbolTableRecord")
         (cons 100 "AcDbLayerTableRecord")
         (cons 2  name)
         (cons 70 bitflag)
         (cons 290 (if willplot 1 0))
         (cons 6
           (if (and linetype (tblsearch "LTYPE" linetype))
             linetype "CONTINUOUS"
           )
         )
         (cons 62 (if (and colour (< 0 (abs colour) 256)) colour 7))
         (cons 370
           (if (minusp lineweight) -3
             (fix
               (* 100
                 (if (and lineweight (<= 0.0 lineweight 2.11)) lineweight 0.0)
               )
             )
           )
         )
       )
       (if description
         (list
           (list -3
             (list "AcAecLayerStandard" (cons 1000 "") (cons 1000 description))
           )
         )
       )
     )
   )
 )
)
(defun c:XT nil (vl-load-com)
 ;; © Lee Mac 2010
 ;; Specifications:
 ;; Description        Data Type        Remarks
 ;; -----------------------------------------------------------------
 ;; Layer Name          STRING          Only standard chars allowed
 ;; Layer Colour        INTEGER         may be nil, -ve for Layer Off, Colour < 256
 ;; Layer Linetype      STRING          may be nil, If not loaded, CONTINUOUS.
 ;; Layer Lineweight    REAL            may be nil, negative=Default, otherwise 0 <= x <= 2.11
 ;; Plot?               BOOLEAN         T = Plot Layer, nil otherwise
 ;; Bit Flag            INTEGER         0=None, 1=Frozen, 2=Frozen in VP, 4=Locked
 ;; Description         STRING          may be nil for no description
 ;; Function will return list detailing whether layer creation is successful.    
 (
   (lambda ( lst / lts ) (setq lts (vla-get-Linetypes (vla-get-ActiveDocument (vlax-get-acad-object))))
     (mapcar 'cons (mapcar 'car lst)
       (mapcar
         (function
           (lambda ( x )
             (and (caddr x)
               (or (tblsearch "LTYPE" (caddr x))
                 (vl-catch-all-apply 'vla-load (list lts (caddr x) "acad.lin"))
               )
             )
             (apply 'MakeLayer x)
           )
         )
         lst
       )
     )
   )
  '(
   ;  Name             Colour       Linetype               Lineweight     Plot?  Bitflag       Description 
   ( "Layer1"         5          "CONTINUOUS"            0.50             T      0              nil )
   ( "Layer2"         6          "ACAD_ISO04W100"     0.18             T      0              nil )
   ( "Layer3"         7          "CONTINUOUS"            0.35             T      0              nil )
   ( "Layer4"         40         "CONTINUOUS"           0.35             T      0              nil )
   ( "Layer5"         4          "DASHEDx2"                0.18             T      0              nil )
   ( "Layer6"         3          "CONTINUOUS"            0.15             T      0              nil )
   ( "Layer7"         11         "CONTINUOUS"           0.15             T      0              nil )
   ( "Layer8"         2          "CONTINUOUS"            0.35             T      0              nil )
   ( "Layer9"         1          "CONTINUOUS"            0.20             T      0              nil )
   )
 )
)