另类拷贝AnotherCopy
本帖最后由 自贡黄明儒 于 2013-6-24 15:22 编辑见wowan整得热闹，我也来凑一凑
自我感觉还是实用的
谁在砸我，轻点呢!!
http://bbs.mjtd.com/thread-101674-1-1.html
;;---------------------------------另类拷贝AnotherCopy
;; 末尾数字+1 自贡黄明儒
;;ayEntSSHighLight见http://bbs.mjtd.com/thread-101674-1-1.html
(defun C:AC (/ P0 SS0)
;;2对象na之后所有实体产生的选择集
(defun newsel (na / ss e1)
(if na
(setq na (entnext na))
(setq na (entnext))
)
(setq ss (ssadd))
(while na
(setq e1 (entget na))
(if (wcmatch (LI_item 0 e1) "VERTEX,SEQEND,ATTRIB")
nil
(setq ss (ssadd na ss))
)
(setq na (entnext na))
)
ss
)
;;3copy
(defun do-copy (ss0 p0 / A BOOL PT SS SS1 SS2)
(setq bool T)
(setq ss ss0
pt p0
)
(while bool
(setq a (entlast))
(princ "\n >>下一点或者输入距离:")
(command "_.copy" ss "" pt pause)
(setq ss1 (newsel a))
(ayEntSSHighLight ss)
(command "._Select" ss1 "")
;(if (setq ss2 (ssget "_p" '((0 . "*TEXT,ATTDEF,INSERT"))))(SA_change ss2))这句让文字尾数+1
(if (equal pt (setq pt (getvar "lastpoint")) 0.001)
(progn (command "undo" "2") (setq bool nil))
)
(setq ss ss1)
;;(princ (getvar 'errno))
)
)
;;4主程序
(command "undo" "be")
(if (and (setq ss0 (ssget))
(setq p0 (getpoint "\n >基点:"))
)
(do-copy ss0 p0)
)
(command "undo" "e")
(princ)
)
;;---------------------------------另类拷贝AnotherCopy (Defun LI_item (N E) (CDR (Assoc N E))) 欢迎提供更多源码，一起学习， 。。。。
感觉自己做的复制没有CAD自带的那样好，CAD自带的复制有一根引线，已经习惯了这个线，。 都是很实用的程序啊，多谢楼主 这句忘了去 ; 号，
我加了一个图层过滤
(if (setq ss2 (ssget "_p" '((8 . "图号2")(0 . "*TEXT,ATTDEF,INSERT"))))(SA_change ss2))这句让文字尾数+1 ; 错误: no function definition: SA_CHANGE 本帖最后由 自贡黄明儒 于 2013-6-24 15:29 编辑
yoyoho 发表于 2013-6-24 15:11 http://bbs.mjtd.com/static/image/common/back.gif
; 错误: no function definition: SA_CHANGE
;;练习正则表达式，文字最后数字加1
(defun C:w1 (/ ENT I REGEX S STR STR1 STR2)
(setq ent (car (entsel))) ;选择文字
(setq regex (vlax-create-object "Vbscript.RegExp")) ;引用正则表达式控件
;;(vlax-put-property regex "IgnoreCase" 0) ; 不忽略大小写
;;(vlax-put-property regex "Global" 0) ;只匹配第一处
;;(vlax-put-property regex "RightToLeft") ;从右向左查找(语法不对)
(setq str (cdr (assoc 1 (entget ent)))) ;文本内容
(vlax-put-property regex "Pattern" "+$") ;查找规则，提最后一位数字;"+$"最后数字
(setq s (vlax-invoke-method regex "Execute" str)) ;将规则运用到STR字符，得到提取出的文字内容
(VLAX-FOR tmp s
(setq str1 (cons (vlax-get-property tmp "value") str1))
) ;将内容转换为LISP语言就可以直接观察了
(if str1
(progn (setq str2 (itoa (1+ (atoi (car str1))))) ;提取的尾数+1
(setq i (- (strlen (car str1)) (strlen str2)))
(if (> i 0)
(repeat i (setq str2 (strcat "0" str2)))
)
;;(setq s (vlax-invoke-method regex "Replace" str "")) ;字符串前缀
(setq str (vlax-invoke-method regex "Replace" str str2)) ;替换字符串
)
(setq str (strcat str "1"))
)
(vlax-put-property (vlax-ename->vla-object ent) 'TextString str) ;改变特性
(vlax-release-object regex) ;释放正则表达式
(princ)
)
;;小数点后数字加1
(defun C:w2 (/ ENT ENTLIST I QIANZ STR STR1 STR2 STRLEN1 STRLEN2)
(setq ent (car (entsel))) ;选择文字
(setq entlist (entget ent))
(setq str (cdr (assoc 1 entlist))) ;文本内容
(setq strlen1 (strlen str)) ;长度
(setq QianZ (vl-string-right-trim "0123456789" str)) ;去除右边数字
(setq strlen2 (strlen QianZ)) ;前缀长度
(setq str1 (substr str (1+ strlen2) (- strlen1 strlen2))) ;小数点后数字
(if str1
(progn (setq str2 (itoa (1+ (atoi str1)))) ;提取的尾数+1
(setq i (- (strlen str1) (strlen str2)))
(if (> i 0)
(repeat i (setq str2 (strcat "0" str2)))
)
)
(setq str2 "1")
)
(setq str (strcat QianZ str2))
(entmod (subst (cons 1 str) (assoc 1 entlist) entlist))
(princ)
)
自贡黄明儒 发表于 2013-6-24 15:25 static/image/common/back.gif
自贡黄明儒 谢谢! 下载 收藏 谢谢 谢谢 顶起 黄大侠，方不方便帮改成线选择，后按快捷键啊，我想和这个程序合并一下，实现双功能。谢谢你了：
;画圆+多重复制（ProgramFancier）2011.8.21
(defun c:c()
(setq ss (ssget"i"))
(if (= ss nil)(txy)
复制递增........
(defun txy( / pc k e r e1 r1)
(setvar"autosnap"63);; 极轴开（正交55）
(setvar"osmode"6079);; 极轴开对象追踪开对象捕捉开（全部16383）
(setq pc (getpoint "\n中心点:") k t)
(command ".CIRCLE" pc pause)
(while k (setq e (entlast))
(setq r (cdr (assoc 40 (entget e))))
(command ".CIRCLE" pc pause)
(setq e1 (entnext e))
(setq r1 (cdr (assoc 40 (entget e1))))
(if (equal r r1 0.0001) (setq k nil)))
(command "U" "l" "")
(princ))
页:
[1]
2