自动复制递增图号程序

litingkun2002 · 发表于 2018-5-1 19:25:15

附件是我在网上下载的一个自动递增图号的程序。现我想修改图号的由1，2,3变为001，002，003要怎么改程序呢，请教！
附程序用法，1，加载程序，
2，新建定义属性名称为tag
3，将新建的定义属性选中生成为块。

edata · 发表于 2018-5-2 21:32:10

;; modify by edata 2018-5-2
;; 修改自动递增三位数前置0对齐；
;; 修改图块名为 "图框"
;; 修改图块属性名称为 "图号"

;;-----------------=={ AutoLabel Attributes }==---------------;;
;; ;;
;; Automatically labels a specific attribute in a set of ;;
;; blocks, renumbering if blocks are added, copied or ;;
;; erased. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright ?2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Version 1.0 - 14-09-2011 ;;
;;------------------------------------------------------------;;
;;------------------------------------------------------------;;
;; Settings ;;
;;------------------------------------------------------------;;
;; [Note: Block names and Attribute Tags are *not* case-sensitive]
;; modify by edata 2018-5-2
;; 修改自动递增三位数前置0对齐；
;; 修改图块名为 "图框"
;; 修改图块属性名称为 "图号"
(setq *blockname* "图框" ;; 修改需要自动递增的图块名称,如: "图框" ;;Name of Block to be Updated
*blocktag* "图号" ;; 修改需要自动递增的图块属性名称,如: "图号" ;;Attribute Tag to be Updated
)
;;------------------------------------------------------------;;
;; Main Program ;;
;;------------------------------------------------------------;;
(defun ObjectReactorCallback:RenumberBlocks ( object reactor params )
(setq *reactor* reactor)
(vlr-command-reactor "temp" '((:vlr-commandended . CommandReactorCallback:RenumberBlocks)))
(vlr-remove reactor)
(princ)
)
;;------------------------------------------------------------;;
(defun CommandReactorCallback:RenumberBlocks ( reactor params / e f i l n s )
(if reactor (vlr-remove reactor))
(if
(and
(not *undoflag*)
(setq s (ssget "_X" *filter*))
)
(progn
(setq n 0)
(repeat (setq i (sslength s))
(if (eq *blockname*
(AutoLabel:EffectiveName
(setq o (vlax-ename->vla-object (setq e (ssname s (setq i (1- i))))))
)
)
(progn
(setq e (entnext e)
l (entget e)
f nil
)
(while (and (not f) (eq "ATTRIB" (cdr (assoc 0 l))))
(if (eq *blocktag* (strcase (cdr (assoc 2 l))))
(progn
;;添加前置零三位数对齐001,002,003...
(setq f (entmod (subst (cons 1 (cond ((< (1+ n) 10)(strcat "00" (itoa (setq n (1+ n)))))
((< (1+ n) 100)(strcat "0" (itoa (setq n (1+ n)))))
(t (itoa (setq n (1+ n)))))) (assoc 1 l) l)))
)
)
(setq e (entnext e)
l (entget e)
)
)
(if (and *reactor* (not (member o (vlr-owners *reactor*))))
(vlr-owner-add *reactor* o)
)
)
)
)
)
)
(if *reactor*
(progn (vlr-add *reactor*) (setq *reactor* nil))
)
(princ)
)
;;------------------------------------------------------------;;
(defun CommandReactorCallback:UndoCheck ( reactor params )
(setq *undoflag* (wcmatch (strcase (car params)) "*U,*UNDO"))
(princ)
)
;;------------------------------------------------------------;;
(defun CommandReactorCallback:BlockInserted ( reactor params / e l )
(if
(and
(not *undoflag*)
(wcmatch (strcase (car params)) "*I,*INSERT,*EXECUTETOOL")
(setq e (entlast))
(setq l (entget e))
(eq "INSERT" (cdr (assoc 0 l)))
(= 1 (cdr (assoc 66 l)))
(eq *blockname* (AutoLabel:EffectiveName (vlax-ename->vla-object e)))
)
(AutoLabel:GetNewNumber e)
)
(princ)
)
;;------------------------------------------------------------;;
(defun AutoLabel:GetNewNumber ( ent / e f i l n r s )
(if (setq s (ssget "_X" *filter*))
(progn
(setq n 0)
(repeat (setq i (sslength s))
(if (eq *blockname*
(AutoLabel:Effectivename
(vlax-ename->vla-object (ssname s (setq i (1+ i))))
)
)
(setq n (1+ n))
)
)
(setq e (entnext ent)
l (entget e)
)
(while (and (not f) (eq "ATTRIB" (cdr (assoc 0 l))))
(if (eq *blocktag* (strcase (cdr (assoc 2 l))))
(progn
(setq f (entmod (subst (cons 1 (cond ((< n 10)(strcat "00" (itoa n)))
((< n 100)(strcat "0" (itoa n)))
(t (itoa n)))) (assoc 1 l) l)))
)
)
(setq e (entnext e)
l (entget e)
)
)
(if
(setq r
(vl-some
(function
(lambda ( r ) (if (eq *reacdata* (vlr-data r)) r))
)
(cdar (vlr-reactors :vlr-object-reactor))
)
)
(vlr-owner-add r (vlax-ename->vla-object ent))
)
)
)
(princ)
)
;;------------------------------------------------------------;;
(defun AutoLabel:EffectiveName ( obj )
(strcase
(if (vlax-property-available-p obj 'effectivename)
(vla-get-effectivename obj)
(vla-get-name obj)
)
)
)
;;------------------------------------------------------------;;
;; Loading Expressions ;;
;;------------------------------------------------------------;;
(vl-load-com)
(
(lambda ( / i s l o )
(setq
*blocktag* (strcase *blocktag*)
*blockname* (strcase *blockname*)
*reacdata* "AutoBlockLabel"
*reactor* nil
*undoflag* nil
)
(foreach r1 (vlr-reactors)
(foreach r2 (cdr r1)
(if (eq *reacdata* (vlr-data r2)) (vlr-remove r2))
)
)
(if
(setq s
(ssget "_X"
(setq *filter*
(list
'(0 . "INSERT")
'(66 . 1)
(cons 2 (strcat "`*U*," *blockname*))
(cons 410 (getvar 'CTAB))
)
)
)
)
(progn
(repeat (setq i (sslength s))
(if (eq *blockname*
(AutoLabel:EffectiveName
(setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
)
)
(setq l (cons o l))
)
)
(CommandReactorCallback:RenumberBlocks nil nil)
(vlr-object-reactor l *reacdata*
(list
(cons :vlr-erased 'ObjectReactorCallback:RenumberBlocks)
(cons :vlr-copied 'ObjectReactorCallback:RenumberBlocks)
(cons :vlr-unerased 'ObjectReactorCallback:RenumberBlocks)
)
)
(vlr-command-reactor *reacdata*
(list
(cons :vlr-commandwillstart 'CommandReactorCallback:UndoCheck)
(cons :vlr-commandended 'CommandReactorCallback:BlockInserted)
)
)
)
)
)
)
(princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;

;;-----------------=={ AutoLabel Attributes }==---------------;; 
;;                                                            ;; 
;;  Automatically labels a specific attribute in a set of     ;; 
;;  blocks, renumbering if blocks are added, copied or        ;; 
;;  erased.                                                   ;; 
;;------------------------------------------------------------;; 
;;  Author: Lee Mac, Copyright ?2011 - <a href="http://www.lee-mac.com" target="_blank">www.lee-mac.com</a>       ;; 
;;------------------------------------------------------------;; 
;;  Version 1.0    -    14-09-2011                            ;; 
;;------------------------------------------------------------;; 
 
;;------------------------------------------------------------;; 
;;                         Settings                           ;; 
;;------------------------------------------------------------;; 
 
;; [Note: Block names and Attribute Tags are *not* case-sensitive] 
;; modify by edata 2018-5-2 
;; 修改自动递增三位数前置0对齐； 
;; 修改图块名为 "图框" 
;; 修改图块属性名称为 "图号" 
 
(setq *blockname* "图框"  ;; 修改需要自动递增的图块名称,如: "图框" ;;Name of Block to be Updated 
      *blocktag*  "图号"    ;; 修改需要自动递增的图块属性名称,如: "图号" ;;Attribute Tag to be Updated 
) 
 
;;------------------------------------------------------------;; 
;;                      Main Program                          ;; 
;;------------------------------------------------------------;; 
 
(defun ObjectReactorCallback:RenumberBlocks ( object reactor params ) 
    (setq *reactor* reactor) 
    (vlr-command-reactor "temp" '((:vlr-commandended . CommandReactorCallback:RenumberBlocks))) 
    (vlr-remove  reactor) 
    (princ) 
) 
 
;;------------------------------------------------------------;; 
 
(defun CommandReactorCallback:RenumberBlocks ( reactor params / e f i l n s ) 
    (if reactor (vlr-remove reactor)) 
    (if 
        (and 
            (not *undoflag*) 
            (setq s (ssget "_X" *filter*)) 
        ) 
        (progn 
            (setq n 0) 
            (repeat (setq i (sslength s)) 
                (if (eq *blockname* 
                        (AutoLabel:EffectiveName 
                            (setq o (vlax-ename->vla-object (setq e (ssname s (setq i (1- i)))))) 
                        ) 
                    ) 
                    (progn 
                        (setq e (entnext e) 
                              l (entget  e) 
                              f nil 
                        ) 
                        (while (and (not f) (eq "ATTRIB" (cdr (assoc 0 l)))) 
                            (if (eq *blocktag*  (strcase (cdr (assoc 2 l)))) 
            (progn 
        ;;添加前置零三位数对齐001,002,003... 
                                (setq f (entmod (subst (cons 1 (cond ((< (1+ n) 10)(strcat "00" (itoa (setq n (1+ n))))) 
                     ((< (1+ n) 100)(strcat "0" (itoa (setq n (1+ n))))) 
                     (t (itoa (setq n (1+ n)))))) (assoc 1 l) l))) 
        ) 
                            ) 
                            (setq e (entnext e) 
                                  l (entget  e) 
                            ) 
                        ) 
                        (if (and *reactor* (not (member o (vlr-owners *reactor*)))) 
                            (vlr-owner-add *reactor* o) 
                        ) 
                    ) 
                ) 
            ) 
        ) 
    ) 
    (if *reactor* 
        (progn (vlr-add *reactor*) (setq *reactor* nil)) 
    ) 
    (princ) 
) 
 
;;------------------------------------------------------------;; 
 
(defun CommandReactorCallback:UndoCheck ( reactor params ) 
    (setq *undoflag* (wcmatch (strcase (car params)) "*U,*UNDO")) 
    (princ) 
) 
 
;;------------------------------------------------------------;; 
 
(defun CommandReactorCallback:BlockInserted ( reactor params / e l ) 
    (if 
        (and 
            (not *undoflag*) 
            (wcmatch (strcase (car params)) "*I,*INSERT,*EXECUTETOOL") 
            (setq e (entlast)) 
            (setq l (entget e)) 
            (eq "INSERT" (cdr (assoc 0 l))) 
            (= 1 (cdr (assoc 66 l))) 
            (eq *blockname* (AutoLabel:EffectiveName (vlax-ename->vla-object e))) 
        ) 
        (AutoLabel:GetNewNumber e) 
    ) 
    (princ) 
) 
 
;;------------------------------------------------------------;; 
 
(defun AutoLabel:GetNewNumber ( ent / e f i l n r s ) 
    (if (setq s (ssget "_X" *filter*)) 
        (progn 
            (setq n 0) 
            (repeat (setq i (sslength s)) 
                (if (eq *blockname* 
                        (AutoLabel:Effectivename 
                            (vlax-ename->vla-object (ssname s (setq i (1+ i)))) 
                        ) 
                    ) 
                    (setq n (1+ n)) 
                ) 
            ) 
            (setq e (entnext ent) 
                  l (entget e) 
            ) 
            (while (and (not f) (eq "ATTRIB" (cdr (assoc 0 l)))) 
                (if (eq *blocktag*  (strcase (cdr (assoc 2 l)))) 
      (progn 
                    (setq f (entmod (subst (cons 1 (cond ((< n 10)(strcat "00" (itoa n))) 
                     ((< n 100)(strcat "0" (itoa n))) 
                     (t (itoa n)))) (assoc 1 l) l))) 
        ) 
                ) 
                (setq e (entnext e) 
                      l (entget  e) 
                ) 
            ) 
            (if 
                (setq r 
                    (vl-some 
                        (function 
                            (lambda ( r ) (if (eq *reacdata* (vlr-data r)) r)) 
                        ) 
                        (cdar (vlr-reactors :vlr-object-reactor)) 
                    ) 
                ) 
                (vlr-owner-add r (vlax-ename->vla-object ent)) 
            )                            
        ) 
    ) 
    (princ) 
) 
 
;;------------------------------------------------------------;; 
 
(defun AutoLabel:EffectiveName ( obj ) 
    (strcase 
        (if (vlax-property-available-p obj 'effectivename) 
            (vla-get-effectivename obj) 
            (vla-get-name obj) 
        ) 
    ) 
) 
 
;;------------------------------------------------------------;; 
;;                   Loading Expressions                      ;; 
;;------------------------------------------------------------;; 
 
(vl-load-com) 
 
( 
    (lambda ( / i s l o ) 
        (setq 
            *blocktag*  (strcase *blocktag*) 
            *blockname* (strcase *blockname*) 
            *reacdata*  "AutoBlockLabel" 
            *reactor*   nil 
            *undoflag*  nil 
        ) 
        (foreach r1 (vlr-reactors) 
            (foreach r2 (cdr r1) 
                (if (eq *reacdata* (vlr-data r2)) (vlr-remove r2)) 
            ) 
        ) 
        (if 
            (setq s 
                (ssget "_X" 
                    (setq *filter* 
                        (list 
                           '(0 . "INSERT") 
                           '(66 . 1) 
                            (cons 2 (strcat "`*U*," *blockname*)) 
                            (cons 410 (getvar 'CTAB)) 
                        ) 
                    ) 
                ) 
            ) 
            (progn 
                (repeat (setq i (sslength s)) 
                    (if (eq *blockname* 
                            (AutoLabel:EffectiveName 
                                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i))))) 
                            ) 
                        ) 
                        (setq l (cons o l)) 
                    ) 
                ) 
                (CommandReactorCallback:RenumberBlocks nil nil) 
                (vlr-object-reactor l *reacdata* 
                    (list 
                        (cons :vlr-erased   'ObjectReactorCallback:RenumberBlocks) 
                        (cons :vlr-copied   'ObjectReactorCallback:RenumberBlocks) 
                        (cons :vlr-unerased 'ObjectReactorCallback:RenumberBlocks) 
                    ) 
                ) 
                (vlr-command-reactor *reacdata* 
                    (list 
                        (cons :vlr-commandwillstart 'CommandReactorCallback:UndoCheck) 
                        (cons :vlr-commandended     'CommandReactorCallback:BlockInserted) 
                    ) 
                ) 
            ) 
        ) 
    ) 
) 
 
(princ) 
 
;;------------------------------------------------------------;; 
;;                         End of File                        ;; 
;;------------------------------------------------------------;;

litingkun2002 · 发表于 2018-5-3 22:42:03

高人，谢谢！

paulpipi · 发表于 2019-7-24 07:26:09

灰石Jeremy · 发表于 2020-5-6 21:39:30

谢谢大神指导，学到了~

小小的人 · 发表于 2020-6-3 17:17:32

edata 发表于 2018-5-2 21:32
;; modify by edata 2018-5-2
;; 修改自动递增三位数前置0对齐；
;; 修改图块名为 "图框"

什么命令执行呢

陈伟 · 发表于 2021-12-9 11:16:55

本帖最后由陈伟于 2021-12-9 11:24 编辑

edata 发表于 2018-5-2 21:32
;; modify by edata 2018-5-2
;; 修改自动递增三位数前置0对齐；
;; 修改图块名为 "图框"

想改成要前缀的，数值保留两位如“建施-01” “建施-02”，求帮修改一下如果能每复制一次或删除图框一次，能对图框的图号重新排一次就好了（从上至下，或者从左至右排序），这样出图的时候就不用重新对图号排序了

rocking2008 · 发表于 2021-12-15 22:24:05

edata 发表于 2018-5-2 21:32
;; modify by edata 2018-5-2
;; 修改自动递增三位数前置0对齐；
;; 修改图块名为 "图框"

如果一张图里面有多种图框样式，例如块名为：A3图框，A4图框，加长图框，用户图框，如何让程序支持多个块名？

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

[讨论] 自动复制递增图号程序

本帖子中包含更多资源

点评