[编程交流] 复制/重命名层

(defun c:Test (/ ss p1 p2 i sn lst l)
 ;;___ Tharwat 12. May. 2013 ___;;
 (if
   (and
     (setq ss (ssget "_:L"))
     (setq p1 (getpoint "\n Specify base point :"))
     (setq p2 (acet-ss-drag-move ss p1 "\n Specify second point :"))
     (repeat (setq i (sslength ss))
       (setq sn (ssname ss (setq i (1- i))))
       (setq lst (cons (vla-copy (vlax-ename->vla-object sn)) lst))
     )
   )
    (progn
      (foreach e lst
        (vla-move e (vlax-3d-point p1) (vlax-3d-point p2))
      )
      (while
        (and (/= "" (setq l (getstring t "\n Specify New Layer Name :")))
             (snvalid l)
             (tblsearch "LAYER" l)
        )
         (princ
           "\n Unvalid name of layer or it's already existed ! TRY AGAIN "
         )
      )
      (if (not (tblsearch "LAYER" l))
        (progn
          (vla-add (vla-get-layers
                     (vla-get-activedocument (vlax-get-acad-object))
                   )
                   l
          )
          (foreach o lst (vla-put-layer o l))
        )
      )
    )
 )
 (princ "\n Written by Tharwat ...")
 (princ)
)
(vl-load-com)

        (defun ListBox (title msg keylab flag / tmp file dcl_id choice)
        ;; ListBox (gile)
        ;; Dialog box to choose one or more in a list
        ;;
        ;; Arguments
        ;; title : the dialog title (string)
        ;; msg ; message (string), "" or nil for none
        ;; keylab : an dotted pairs list of type ((key1 . label1) (key2 . label2) ...)
        ;; flag : 0 = popup list
        ;;        1 = single choice list box
        ;;        2 = multipe choices list box
        ;;
        ;; Return value : the choosen key (flag = 0 or 1) or the list of choosen keys (flag = 2)
        ;;
        ;; Using example
        ;; (listbox "Layout" "Choose a layout" (mapcar 'cons (layoutlist) (layoutlist)) 1)
        ;; create and open a temporay file
          (setq        tmp  (vl-filename-mktemp "tmp.dcl")
                file (open tmp "w")
          )
                ;; write the file according to arguments
          (write-line
            (strcat "ListBox:dialog{label="" title "";")
            file
          )
          (if (and msg (/= msg ""))
            (write-line (strcat ":text{label="" msg "";}") file)
          )
          (write-line
            (cond
              ((= 0 flag) "spacer;:popup_list{key="lst";")
              ((= 1 flag) "spacer;:list_box{key="lst";allow_accept = true;")
              (T "spacer;:list_box{key="lst";multiple_select=true;")
            )
            file
          )
          (write-line "}spacer;ok_cancel;}" file)
          (close file)
                
                ;; load the file and show the dialog
          (setq dcl_id (load_dialog tmp))
          (if (not (new_dialog "ListBox" dcl_id))
            (exit)
          )
          (start_list "lst")
          (mapcar 'add_list (mapcar 'cdr keylab))
          (end_list)
          (action_tile
            "accept"
            "(or (= (get_tile "lst") "")
            (if (= 2 flag) (progn
            (foreach n (str2lst (get_tile "lst") " ")
            (setq choice (cons (nth (atoi n) (mapcar 'car keylab)) choice)))
            (setq choice (reverse choice)))
            (setq choice (nth (atoi (get_tile "lst")) (mapcar 'car keylab)))))
            (done_dialog)"
          )
          (start_dialog)
          (unload_dialog dcl_id)
          (vl-file-delete tmp)
          choice
        )
(defun make-copy-layer (New_Layer_Name Owner_Layer_Name / tmp ) 
;;;http://www.caduser.ru/forum/index.php?PAGE_NAME=message&FID=2&TID=47868&PAGEN_1=2
;;;Functionh to create a copy of the layer
;;; New_Layer_Name - the name of the new layer
;;; Owner_Layer_Name - name of the copied layer
;;; Returns ename copy created layer or nil
;;; (Make-copy-layer "My new layer" "0")
 (if (and (setq tmp (tblobjname "LAYER" Owner_Layer_Name)) 
          (setq tmp (entget tmp)) 
          (snvalid New_Layer_Name 0) 
          (not (tblsearch "LAYER" New_Layer_Name)) 
          ) 
   (entmakex (subst (cons 2 New_Layer_Name)(assoc 2 tmp) tmp)) 
   ) 
 )
;;;Written By Michael Puckett. 
;;;(setq all_layers (tablelist "LAYER"))
 (defun tablelist (s / d r)
     (while (setq d (tblnext s (null d)))
       (setq r (cons (cdr (assoc 2 d)) r))
     );_ while
   );_ defun
(defun c:test ( / e1 _l _n _nl ) 
(if 
  (setq e1 (entsel "\nPlease select a primitive copy of the layer you want to get <exit>: ")) 
  (progn       
      (print (setq _l (cdr(assoc 8 (entget(car e1)))))) 
      (setq _nl (getstring t "\nNew layer name: ")) 
      (if (make-copy-layer  _nl _l) (setvar "clayer" _nl)) 
  )) 
);defun
(defun C:test1 ( / _nl _l )
 (vl-load-com)
 (and
 (setq _l  
 (listbox "Layer" "Select exist layer"
   ((lambda(l)(mapcar 'cons l l))(vl-remove-if-not 'snvalid (tablelist "LAYER")))
   1
   )
)
 (setq _nl (getstring t "\nNew layer name: "))
 (snvalid _nl 0)
 (if (make-copy-layer  _nl _l) (setvar "clayer" _nl))
 )
(princ)
 )
 (princ "\n type Test or Test1 in command line")(princ)