[编程交流] Duplayout LISP

(defun c:duplayout ( /
                   increment_string CustSort CustSort_Comparable CustSort_SplitStr
                   oce louts flag ctab layout# layoutname newlayoutname )
 
 (vl-load-com)
 ;;******************************************************************
 ;; Local Functions
 ;;******************************************************************
 (defun increment_string (string inc / num tmp1 len check sign)
   (if (/= string "");Don't process an empty string
     (progn
       (setq num ""
             tmp1 1
             )
       (while (and (> (setq len (strlen string)) 0) tmp1)
         (setq check (substr string len));The last character of the string
         (if (wcmatch check "[0-9]");Is it a number?
           (setq num (strcat check num);If yes put it aside
                 string (substr string 1 (1- len));and take it off the original string
                 )
           (setq tmp1 nil);If no end the loop
           );if
         );while
       
       ;check for negative signage in front of the string
       (if (and (> (strlen string) 0) (= (substr string 1 1) "-"))
         (progn
           (setq sign -1)
           (if (> (strlen string) 1);more than just a negative sign
             (setq string (vl-string-left-trim " " (substr string 2 (1- (strlen string)))));remove the negative sign and any spaces
             (setq string "")
             )
           );progn
         (setq sign 1)
         )
       
       
       
       (setq tmp1 (+ (* (atoi num) sign) inc)
             sign (if (< tmp1 0) "-" "")
             tmp1 (itoa (abs tmp1))
             )
       
       ;Then pad with zeros if the original was padded
       (if (< (strlen tmp1) (strlen num))
         (repeat (- (strlen num) (strlen tmp1)) (setq tmp1 (strcat "0" tmp1)));Buffer with zeros
         )
       (strcat sign string tmp1)
       );progn
     "1"
     );if
   )
 
 ;;******************************************************************
 ;;Customised string sorting function Main Part
 (defun CustSort ( x )
   (vl-sort x (function (lambda ( x1 x2 / n1 n2 comp )
                          (setq x1 (CustSort_SplitStr x1);creates a broken down list of alpha & numeric values from the string
                                x2 (CustSort_SplitStr x2);creates a broken down list of alpha & numeric values from the string
                                )
                          (while
                            (and
                              (setq comp (CustSort_Comparable (setq n1 (car x1)) (setq n2 (car x2))))
                              (= n1 n2)
                              (/= n1 nil)
                              )
                            (setq x1 (cdr x1) x2 (cdr x2))
                            );while
                          (if comp (< n1 n2) (numberp n1))
                          );lambda
                        );function
            );vl-sort
   )
 
 ;*********************************************************************
 ;;Customised string sorting function Sub Part 1 - Tests whether the values are both strings or both numbers
 (defun CustSort_Comparable ( e1 e2 )
   (or
     (and (numberp e1) (numberp e2))
     (= 'STR (type e1) (type e2))
     (not e1)
     (not e2)
     )
   )
 
 ;*********************************************************************
 ;;Customised string sorting function Sub Part 2 - Splits a string into a list of separated string and number parts
 (defun CustSort_SplitStr ( str / lst test rslt num tmp )
   (setq lst  (vl-string->list str)
         test (chr (car lst))
         )
   (if (< 47 (car lst) 58) (setq num T))
   (while (setq lst (cdr lst))
     (if num
       (cond
         ((= 46 (car lst))
          (if (and (cadr lst) (setq tmp (strcat "0." (chr (cadr lst)))) (numberp (read tmp)))
            (setq rslt (cons (read test) rslt) test tmp lst (cdr lst))
            (setq rslt (cons (read test) rslt) test "." num nil))
          );1st condition
         ((< 47 (car lst) 58)
          (setq test (strcat test (chr (car lst))))
          );2nd condition
         (T (setq rslt (cons (read test) rslt)
                  test (chr (car lst))
                  num  nil
                  )
          );3rd condition
         );cond
       (if (< 47 (car lst) 58)
         (setq rslt (cons test rslt) test (chr (car lst)) num T)
         (setq test (strcat test (chr (car lst)))));if
       );if
     );while
   (if num (setq rslt (cons (read test) rslt)) (setq rslt (cons test rslt)))
   (reverse rslt)
   )
 
 ;;******************************************************************
 ;; Main Program Code
 ;;******************************************************************
 
 (setq oce (getvar "cmdecho"))
 (setvar "cmdecho" 0)
 
 (setq louts (layoutlist)
       ctab (if (= "Model" (getvar "ctab")) (car louts) (getvar "ctab"))
       flag nil
       )
 
 (while (not flag)
   (setq layoutname (getstring T (strcat "\nLayout to duplicate <" ctab ">: ")))
   (if (= layoutname "") (setq layoutname ctab))
   (if (= layoutname "Model")
     (alert "Cannot duplicate Modelspace")
     (if (member (strcase layoutname) (mapcar 'strcase louts)) (setq flag T))
     );if
   );while
 
 (initget 6)
 (setq layout# (getint "\nHow many copies ? <2>: "))
 (if (null layout#) (setq layout# 2))
 
 (setq newlayoutname layoutname
       louts (mapcar 'strcase louts)
       )
 
 (repeat layout#
   (while (member (strcase (setq newlayoutname (increment_string newlayoutname 1))) louts))
   (vl-cmdf ".layout" "copy" layoutname newlayoutname)
   (setq louts (cons (strcase newlayoutname) louts))
   );repeat
 
 (setq louts (CustSort louts))
 (vlax-for tab (vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
   (if (not (= (strcase (vla-get-name tab)) "MODEL"))
     (vla-put-taborder tab (1+ (vl-position (strcase (vla-get-name tab)) louts)))
     )
   )
 
 (setvar "cmdecho" oce)
 (princ)
 );defun