另类拷贝AnotherCopy

自贡黄明儒 · 发表于 2013-6-24 13:45:47

本帖最后由自贡黄明儒于 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
)
;;3 copy
(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

;;---------------------------------另类拷贝AnotherCopy 
;; 末尾数字+1 自贡黄明儒 
;;ayEntSSHighLight见<a href="http://bbs.mjtd.com/thread-101674-1-1.html" target="_blank">http://bbs.mjtd.com/thread-101674-1-1.html</a> 
(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 
  ) 
  ;;3  copy 
  (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

自贡黄明儒 · 发表于 2013-6-24 13:47:12

(Defun LI_item (N E) (CDR (Assoc N E)))

OWEN7 · 发表于 2013-6-24 13:48:06

欢迎提供更多源码，一起学习，。。。。

感觉自己做的复制没有CAD自带的那样好，CAD自带的复制有一根引线，已经习惯了这个线，。

海盗曹 · 发表于 2013-6-24 13:55:00

都是很实用的程序啊，多谢楼主

669423907 · 发表于 2013-6-24 14:00:40

这句忘了去 ; 号，
我加了一个图层过滤
(if (setq ss2 (ssget "_p" '((8 . "图号2")(0 . "*TEXT,ATTDEF,INSERT"))))(SA_change ss2))这句让文字尾数+1

yoyoho · 发表于 2013-6-24 15:11:40

; 错误: no function definition: SA_CHANGE

自贡黄明儒 · 发表于 2013-6-24 15:25:21

本帖最后由自贡黄明儒于 2013-6-24 15:29 编辑

yoyoho 发表于 2013-6-24 15:11
; 错误: 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" "[0-9]+$") ;查找规则，提最后一位数字;"[0-9]+$"最后数字
(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)
)

;;练习正则表达式，文字最后数字加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" "[0-9]+$")             ;查找规则，提最后一位数字;"[0-9]+$"最后数字 
  (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) 
)

yoyoho · 发表于 2013-6-24 15:40:02

自贡黄明儒发表于 2013-6-24 15:25

自贡黄明儒谢谢!

风雨依然 · 发表于 2013-6-24 15:41:09

下载收藏谢谢谢谢顶起

669423907 · 发表于 2013-7-4 09:18:34

黄大侠，方不方便帮改成线选择，后按快捷键啊，我想和这个程序合并一下，实现双功能。谢谢你了：

;画圆+多重复制（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))

账号		自动登录	找回密码
密码			注册

[源码] 另类拷贝AnotherCopy

评分

点评

点评