[编程交流] 使用lisp gettin重命名层

;;function to rename a layer.
;;if old layer exists, and new layer doesn't exist, the old layer is simply renamed.
;;if old layer exists, and new layer is already there, it takes everything on old layer and puts them on new layer.
;;if old layer doesn't exist, it does nothing.
(defun renlay (ol nl / ss i ent )
 (cond ((and (tblsearch "layer" ol) (not (tblsearch "layer" nl))) 
 (command "._rename" "la" ol nl)
)
((and (tblsearch "layer" ol)(tblsearch "layer" nl))
  (setq ss (ssget "x" (list (cons 8 ol))))
  (setq i -1)
   (repeat (sslength ss)
      (setq ent (entget (ssname ss (setq i (1+ i))))
     ent (subst (cons 8 nl) (cons 8 (cdr (assoc 8 ent))) ent)
      )    
      (entmod ent)
          )
)
((not (tblsearch "layer" ol))
  (prompt (strcat "\nLayer " ol " not found. "))
       )
 )
 (princ)
)
;;example
(defun c:test ()
 (renlay "ENG" "GE_TXT_LANGUAGE_EN")
 (renlay "NL" "GE_TXT_LANGUAGE_DU")
 (renlay "DUITS" "GE_TXT_LANGUAGE_GE")
 (renlay "FR" "GE_TXT_LANGUAGE_FR")
)

(defun RenameLayer ( old new )
 ;; © Lee Mac 2010
 (if (tblsearch "LAYER" old)
   (if (tblsearch "LAYER" new)
     (if (setq ss (ssget "_X" (list (cons 8 old))))
       (
         (lambda ( i )
           (while (setq e (ssname ss (setq i (1+ i))))
             (entupd
               (cdr
                 (assoc -1
                   (entmod
                     (list (assoc -1 (entget e)) (cons 8 new))
                   )
                 )
               )
             )
           )
         )
         -1
       )
     )
     (
       (lambda ( old )
         (entmod
           (subst
             (cons 2 new) (assoc 2 old) old
           )
         )
       )
       (entget (tblobjname "LAYER" old))
     )
   )
   (princ (strcat "\n--> Layer: " old " not found."))
 )
 (princ)
)
(defun c:test ( / o n )
 (if
   (and
     (setq o (getstring t "\nSpecify Layer to be Renamed: "))
     (setq n (getstring t "\nSpecify New Layer Name: "))
   )
   (RenameLayer o n)
 )
 (princ)
)

(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
           (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:MakeLayers 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, 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
    (    "CEN"         6           "CENTER"           0.18            T             0               nil      )
    (    "DIMS"       -1             nil              0.18            T             0               nil      )
    (    "HAT"         3             nil              0.18            T             0               nil      )
    (    "HID"         4           "HIDDEN"           0.15            T             0             "Hidden"   )
    (    "LOGO"       176            nil              0.09            T             0            "For Logo"  )
    (    "OBJ"        -2             nil              0.40            T             0               nil      )
    (    "PAPER"       5           "PHANTOM"           nil            T             0               nil      )
    (    "PHAN"        6           "PHANTOM"          0.18            T             0               nil      )
    (    "TITLE"      176            nil               nil            T             0            "For Title" )
    (    "TXT"         7             nil               nil            T             0               nil      )
   )
 )
)

(dolayers);creates new layers if not already there.
(setlayernew);will merge all old layers that are set with the new ones.

;;function to rename a layer.
;;if old layer exists, and new layer doesn't exist, the old layer is simply renamed.
;;if old layer exists, and new layer is already there, it takes everything on old layer and puts them on new layer.
;;if old layer doesn't exist, it does nothing.
(defun renlay (ol nl / ss i ent )
 (cond ((and (tblsearch "layer" ol) (not (tblsearch "layer" nl))) 
 (command "._rename" "la" ol nl)
)
((and (tblsearch "layer" ol)(tblsearch "layer" nl))
(command "-LAYMRG" "N" ol "" "N" nl "Y")
       )
((not (tblsearch "layer" ol))
 
  (prompt (strcat "\nLayer " ol " not found. "))
       )
 )
 (princ)
)
;;example
(defun c:setlayernew ()
 (command "-layer" "s" "0" "")
 (renlay "1" "01 Dimensions")
 (renlay "2" "02 Project dimensions notes")
   (renlay "8" "05 Center")
 (renlay "9" "08 Surrounding")
 (renlay "11" "05 Center")
 (renlay "13" "13 Border")
 (renlay "BORDER" "13 Border")
 (renlay "BORDER-V" "13 Border")
 (renlay "HORIZONTAL REF BOX" "0")
 (renlay "LOGO" "01 Dimensions")
 (renlay "3D" "0")
 (renlay "3d" "0")
  (renlay "Dimension (ISO)" "01 Dimensions")
 (renlay "Visible (ISO)" "0")
 (renlay "Visible Narrow (ISO)" "0")
 (renlay "Border (ISO)" "13 Border")
 (renlay "Title (ISO)" "13 Border")
 (princ)(princ "Layers renamed and merged")  
 )

(defun MkLay (Nme Col lTyp lWgt Plt / lays lay)
 (vl-load-com)
 (setq lays (vla-get-layers
              (vla-get-ActiveDocument
                (vlax-get-acad-object)))
       lay (cond ((tblsearch "LAYER" Nme)
                  (vla-item lays Nme))
                 (t (vla-add lays Nme))))
 (and Col (vla-put-Color lay Col))
 (and lTyp (lTload lTyp) (vla-put-Linetype lay lTyp))
 (and lWgt  (vla-put-LineWeight lay (eval (read (strcat "acLnWt" lWgt)))))
 (and (not Plt) (vla-put-Plottable lay :vlax-false)))
(defun lTload (lTyp)
 (or (tblsearch "LTYPE" lTyp)
     (vla-load
       (vla-get-Linetypes
         (vla-get-ActiveDocument
           (vlax-get-acad-object))) lTyp "acad.lin")))
(defun c:DoLayers ( / )
 (vl-load-com)
 
 (mapcar 'MkLay
         
         '(         "01 Dimensions"           "02 Project dimensions notes"         )  ; Name [str]
         '(         1                           nil                                 )    ; Colours [int]
         '(         nil                     nil              ) ; LineType [str]
         '(         nil                           nil                 )  ; LineWeight [str] 0.18 = "018"
         '(           T                       T     )) ; Plottable (T or nil)
(princ)(princ "New layers set")
 (princ))