Duplayout LISP
你好我已经使用Gile制作的Duplayout LISP有一段时间了（CADtutor论坛），但是我遗漏了两件事，我希望你们能帮我：
使用duplayout时，新布局的名称设置为最后一个字符串1。（即布局名称：4-25，复制x3，新布局名称：4-26，4-27，4-28），我已经在脚本中找到将字符串从1更改为X的位置（即布局名称4-25，复制x3，字符串-12，新布局名称：4-37，4-49，4-61）。如果它要求以1为基数的字符串值（就像它对要复制的布局和副本数所做的那样），那就太好了。
第二个问题是在第一个字符后进行更改/命名（即布局名称4-25，副本x3，新布局名称：5-25，6-25，7-25）。它还可以要求角色在后面命名（最后加上base）。要更改的字符不经常超过3个，所以它可以要求第一个、最后一个、中间个或类似的字符。如果太难，它只能要求第一个，最后一个
谢谢你的帮助。
(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 "");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))
numnil
)
);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 流血，
我混合使用了以下内容，您可能希望探索这些内容：
使用类固醇重命名：
http://www.cadforum.cz/cadforum_en/rename-on-steroids-complex-renaming-of-autocad-objects-tip9265
在此处张贴#16（需要安装AUGI登录和AutoCAD VBA Enabler）：
http://forums.augi.com/showthread.php?17630-自动重新编号布局选项卡/页面2
标签排序：
http://www.lee-mac.com/tabsort.html
干杯 @abra CAD abra
感谢您的回复，我有这些LISP，有时我会使用它们，但是现在我需要复制许多布局才能使用它们，所以我正在寻找更简单、更快的方法；]现在我需要复制大约120-150个布局：/
页:
[1]