[分享]：批量修改图签程序

szkevin · 发表于 2006-4-9 20:45:15

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

在这里感谢eachy编的批量修改图签程序
这个程序运行时图纸必段同时满足以下三个条件
1.图框为块
2.图框在TK开头的图层上,
3,图号为定义为属性
本程序可以将选中的文件(支恃多选)一次性改成输入的新值,对于程序才能识别的属性,用户可以自行增减,下载的附件中包含了三个样图.
本程序对图形空间和纸空间同样有效.
当输入为空时不做修改.

声明:运行本程序时请对原图做备份,以避免程序运行错误时将原图遭破坏的严重后查!!!

(vl-load-com)
;; for Windows XP / winnt2k
;; (xdl-getfiles) 选取多个文件，返回目录文件列表
;;=============================================================
;; ***免责声明*** |
;; 本程序仅提供作为应用上的参考, 而未声明或隐含任何保证； |
;; 对于任何特殊用途之适应性, 以及商业销售所隐含作出的保证, |
;; 在此一概予以否认。 |
;;=============================================================
(defun xdl-getfiles (/ initdir maxfs flags diatl filter wincomdlg filem fstr->lst)
(defun fstr->lst (fm / n ff)
(setq ff nil)
(if (vl-string-position (ascii "\000") fm)
(progn
(while (vl-string-position (ascii "\000") fm)
(setq n (vl-string-position (ascii "\000") fm))
(setq ff (append ff (list (substr fm 1 n))))
(setq fm (substr fm (+ n 2) (- (strlen fm) n 1)))
)
(setq ff (append ff (list fm)))
)
(progn
(setq ff (vl-filename-directory fm))
(setq ff (list ff (vl-string-subst "" ff fm)))
)
)
)
(setq initdir (getvar "dwgprefix"))
(if
(/=
(vl-registry-read
"HKEY_CLASSES_ROOT\\Licenses\\4D553650-6ABE-11CF-8ADB-00AA00C00905"
)
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
)
(progn
(princ
"\n第一次运行需要注册控件,程序自动注册,请重新启动系统"
)
(VL-REGISTRY-WRITE
"HKEY_CLASSES_ROOT\\Licenses\\4D553650-6ABE-11CF-8ADB-00AA00C00905"
""
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
)
(startapp
"Regsvr32"
(strcat " /s " (getenv "Windir") "\\System32\\comdlg32.ocx")
)
(exit)
)
(progn
(setq wincomdlg (vlax-create-object "mscomdlg.commondialog"))
(vlax-put-property wincomdlg 'CancelError 0)
(vlax-put-property wincomdlg 'MAXFILESIZE 32767)
(vlax-put-property
wincomdlg
'FLAGS
(+ 4 512 524288 1048576 1024)
)
(vlax-put-property
wincomdlg
'DIALOGTITLE
"请选择要修改的DWG文件"
)
(vlax-put-property wincomdlg 'filter "*.dwg|*.dwg")
(vlax-put-property wincomdlg 'initdir initdir)
(vlax-invoke-method wincomdlg 'showopen)
(setq filem (vlax-get wincomdlg 'filename))
(vlax-release-object wincomdlg)
(if (/= filem "")
(mapcar '(lambda (x) (vl-string-left-trim "\" x))
(fstr->lst filem)
)
)
)
)
)
(defun c:DwgATT (/ fls vers date dbx dwgprefix cname1 cname2 pname hname olderr
myerr *acadapp* chgatt _dwgatt_id vers attlst notopen chk_chg Tname getchanged
chgattobj kw
)
(defun myerr (msg)
(if (/= msg "CANCEL")
(princ msg)
)
(if dbx
(vlax-release-object dbx)
)
(setq *error* olderr)
(princ)
)
(defun chgattobj (object atl)
(if
(and
(wcmatch (vlax-get-property object 'objectname)
"*BlockRef*"
)
(wcmatch (vlax-get-property object 'name) "[tT][kK]*")
(= (vlax-get-property object 'hasattributes)
:vlax-true
)
)
(progn
(mapcar
'(lambda (att / tag)
(if (assoc (setq tag (vlax-get-property att 'tagstring))
atl
)
(progn
(vlax-put-property
att
'textstring
(cadr (assoc tag atl))
)
(setq chk_chg T)
)
)
)
(vlax-invoke object "GetAttributes")
)
)
)
)
(defun getchanged (/ attlst)
(mapcar
'(lambda (x y)
(if (and (get_tile x) (/= (get_tile x) ""))
(progn (set (read x) (get_tile x))
(setq attlst (cons (list y (eval (read x))) attlst))
)
)
)
'("date" "vers" "cname1" "cname2" "Pname" "Hname" "Tname")
'("日期" "版次" "建设单位1" "建设单位2" "工程名称" "合同号" "图别")
)
attlst
)
(initget "Y N")
(setq kw
(getkword
"\n 正在运行批量修改图签的程序,请将原图做好备份! 是否继续[Y/N]<N>: "
)
)
(if (= kw "Y")
(progn
(setq *acadapp* (vlax-get-acad-object))
(setq dbx (vlax-invoke-method
*acadapp*
'GetInterfaceObject
(strcat "ObjectDBX.AxDbDocument."
(substr (getvar "acadver") 1 2)
)
)
)
(setq olderr *error*
*error* myerr
)
(if (and dbx
(setq fls (xdl-getfiles))
)
(progn
(if (not _dwgatt_id)
(setq _dwgatt_id (load_dialog "dwgatt.dcl"))
)
(if (not (new_dialog "dwgatt" _dwgatt_id))
(exit)
)
(action_tile
"accept"
"(setq attlst (getchanged))(done_dialog 0)"
)
(start_dialog)
(unload_dialog _dwgatt_id)
(if attlst
(progn
(setq dwgprefix (strcat (car fls) "\")
fls (mapcar '(lambda (x)
(strcat dwgprefix x)
)
(cdr fls)
)
)
(textscr)
(mapcar
'(lambda (x / obj)
(if (not dbx)
(setq
dbx (vlax-invoke-method
*acadapp*
'GetInterfaceObject
(strcat "ObjectDBX.AxDbDocument."
(substr (getvar "acadver") 1 2)
)
)
)
)
(vl-catch-all-apply
'vlax-invoke-method
(list dbx 'open x :vlax-false)
)
(if (/= (vlax-get-property dbx 'name) "")
(progn
(setq chk_chg nil)
(vlax-for obj
(vlax-get-property dbx 'modelspace)
(chgattobj obj attlst)
)
(vlax-for obj
(vlax-get-property dbx 'paperspace)
(chgattobj obj attlst)
)
(if chk_chg
(progn
(vlax-invoke-method dbx 'saveas x)
(princ (strcat "\n" x " Changed Ok!"))
)
(progn
(setq notopen (cons x notopen))
)
)
(vlax-release-object dbx)
(setq dbx nil)
)
(progn
(setq notopen (cons x notopen))
(vlax-release-object dbx)
(setq dbx nil)
)
)
)
;(cdr fls)
fls
)
(if dbx
(vlax-release-object dbx)
)
(if notopen
(progn
(princ
"\n======================================================================"
)
(princ
"\n以下为未修改文件，可能文件已打开或者为高版本图形或者未找到修改之属性!"
)
(princ
"\n======================================================================"
)
(mapcar
'(lambda (x)
(princ (strcat "\n" x " Not Changed!"))
)
notopen
)
)
)
)
(princ "\n没有输入或用户取消!")
)
)
(princ "\n没有选择文件或不能批量修改!")
)
)
)
(setq *error* olderr)
(princ)
)

(vl-load-com) 
;; for Windows XP / winnt2k 
;; (xdl-getfiles) 选取多个文件，返回目录文件列表 
;;============================================================= 
;;                    ***免 责 声 明***                       | 
;;    本程序仅提供作为应用上的参考, 而未声明或隐含任何保证；  | 
;;    对于任何特殊用途之适应性, 以及商业销售所隐含作出的保证, | 
;;    在此一概予以否认。                                      | 
;;============================================================= 
(defun xdl-getfiles (/ initdir maxfs flags diatl filter        wincomdlg filem        fstr->lst) 
    (defun fstr->lst (fm / n ff) 
        (setq ff nil) 
        (if (vl-string-position (ascii "\000") fm) 
            (progn 
                (while (vl-string-position (ascii "\000") fm) 
                    (setq n (vl-string-position (ascii "\000") fm)) 
                    (setq ff (append ff (list (substr fm 1 n)))) 
                    (setq fm (substr fm (+ n 2) (- (strlen fm) n 1))) 
                ) 
                (setq ff (append ff (list fm))) 
            ) 
            (progn 
                (setq ff (vl-filename-directory fm)) 
                (setq ff (list ff (vl-string-subst "" ff fm))) 
            ) 
        ) 
    ) 
    (setq initdir (getvar "dwgprefix")) 
    (if 
        (/= 
            (vl-registry-read 
                "HKEY_CLASSES_ROOT\\Licenses\\4D553650-6ABE-11CF-8ADB-00AA00C00905" 
            ) 
            "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj" 
        ) 
           (progn 
               (princ 
                   "\n第一次运行需要注册控件,程序自动注册,请重新启动系统" 
               ) 
               (VL-REGISTRY-WRITE 
                   "HKEY_CLASSES_ROOT\\Licenses\\4D553650-6ABE-11CF-8ADB-00AA00C00905" 
                   "" 
                   "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj" 
               ) 
               (startapp 
                   "Regsvr32" 
                   (strcat " /s " (getenv "Windir") "\\System32\\comdlg32.ocx") 
               ) 
               (exit) 
           ) 
           (progn 
               (setq wincomdlg (vlax-create-object "mscomdlg.commondialog")) 
               (vlax-put-property wincomdlg 'CancelError 0) 
               (vlax-put-property wincomdlg 'MAXFILESIZE 32767) 
               (vlax-put-property 
                   wincomdlg 
                   'FLAGS 
                   (+ 4 512 524288 1048576 1024) 
               ) 
               (vlax-put-property 
                   wincomdlg 
                   'DIALOGTITLE 
                   "请选择要修改的DWG文件" 
               ) 
               (vlax-put-property wincomdlg 'filter "*.dwg|*.dwg") 
               (vlax-put-property wincomdlg 'initdir initdir) 
               (vlax-invoke-method wincomdlg 'showopen) 
               (setq filem (vlax-get wincomdlg 'filename)) 
               (vlax-release-object wincomdlg) 
               (if (/= filem "") 
                   (mapcar '(lambda (x) (vl-string-left-trim "\" x)) 
                           (fstr->lst filem) 
                   ) 
               ) 
           ) 
    ) 
) 
(defun c:DwgATT        (/           fls             vers      date         dbx           dwgprefix cname1    cname2         pname           hname     olderr 
                 myerr           *acadapp* chgatt    _dwgatt_id           vers             attlst    notopen         chk_chg   Tname     getchanged 
                 chgattobj kw 
                ) 
    (defun myerr (msg) 
        (if (/= msg "CANCEL") 
            (princ msg) 
        ) 
        (if dbx 
            (vlax-release-object dbx) 
        ) 
        (setq *error* olderr) 
        (princ) 
    ) 
    (defun chgattobj (object atl) 
        (if 
            (and 
                (wcmatch (vlax-get-property object 'objectname) 
                         "*BlockRef*" 
                ) 
                (wcmatch (vlax-get-property object 'name) "[tT][kK]*") 
                (= (vlax-get-property object 'hasattributes) 
                   :vlax-true 
                ) 
            ) 
               (progn 
                   (mapcar 
                       '(lambda        (att / tag) 
                            (if        (assoc (setq tag (vlax-get-property att 'tagstring)) 
                                       atl 
                                ) 
                                (progn 
                                    (vlax-put-property 
                                        att 
                                        'textstring 
                                        (cadr (assoc tag atl)) 
                                    ) 
                                    (setq chk_chg T) 
                                ) 
                            ) 
                        ) 
                       (vlax-invoke object "GetAttributes") 
                   ) 
               ) 
        ) 
    ) 
    (defun getchanged (/ attlst) 
        (mapcar 
            '(lambda (x y) 
                 (if (and (get_tile x) (/= (get_tile x) "")) 
                     (progn (set (read x) (get_tile x)) 
                            (setq attlst (cons (list y (eval (read x))) attlst)) 
                     ) 
                 ) 
             ) 
            '("date" "vers" "cname1" "cname2" "Pname" "Hname" "Tname") 
            '("日期" "版次" "建设单位1"        "建设单位2" "工程名称" "合同号"        "图别") 
        ) 
        attlst 
    ) 
    (initget "Y N") 
    (setq kw 
             (getkword 
                 "\n 正在运行批量修改图签的程序,请将原图做好备份! 是否继续[Y/N]<N>: " 
             ) 
    ) 
 
 
    (if        (= kw "Y") 
        (progn 
 
 
            (setq *acadapp* (vlax-get-acad-object)) 
            (setq dbx (vlax-invoke-method 
                          *acadapp* 
                          'GetInterfaceObject 
                          (strcat "ObjectDBX.AxDbDocument." 
                                  (substr (getvar "acadver") 1 2) 
                          ) 
                      ) 
            ) 
            (setq olderr  *error* 
                  *error* myerr 
            ) 
            (if        (and dbx 
                     (setq fls (xdl-getfiles)) 
                ) 
                (progn 
                    (if        (not _dwgatt_id) 
                        (setq _dwgatt_id (load_dialog "dwgatt.dcl")) 
                    ) 
                    (if        (not (new_dialog "dwgatt" _dwgatt_id)) 
                        (exit) 
                    ) 
                    (action_tile 
                        "accept" 
                        "(setq attlst (getchanged))(done_dialog 0)" 
                    ) 
                    (start_dialog) 
                    (unload_dialog _dwgatt_id) 
                    (if        attlst 
                        (progn 
 
                            (setq dwgprefix (strcat (car fls) "\") 
                                  fls            (mapcar '(lambda (x) 
                                                         (strcat dwgprefix x) 
                                                     ) 
                                                    (cdr fls) 
                                            ) 
                            ) 
                            (textscr) 
                            (mapcar 
                                '(lambda (x / obj) 
                                     (if (not dbx) 
                                         (setq 
                                             dbx (vlax-invoke-method 
                                                     *acadapp* 
                                                     'GetInterfaceObject 
                                                     (strcat "ObjectDBX.AxDbDocument." 
                                                             (substr (getvar "acadver") 1 2) 
                                                     ) 
                                                 ) 
                                         ) 
                                     ) 
                                     (vl-catch-all-apply 
                                         'vlax-invoke-method 
                                         (list dbx 'open x :vlax-false) 
                                     ) 
                                     (if (/= (vlax-get-property dbx 'name) "") 
                                         (progn 
                                             (setq chk_chg nil) 
                                             (vlax-for obj 
                                                           (vlax-get-property dbx 'modelspace) 
                                                 (chgattobj obj attlst) 
                                             ) 
                                             (vlax-for obj 
                                                           (vlax-get-property dbx 'paperspace) 
                                                 (chgattobj obj attlst) 
                                             ) 
 
                                             (if chk_chg 
                                                 (progn 
                                                     (vlax-invoke-method dbx 'saveas x) 
                                                     (princ (strcat "\n" x " Changed Ok!")) 
                                                 ) 
                                                 (progn 
                                                     (setq notopen (cons x notopen)) 
                                                 ) 
                                             ) 
                                             (vlax-release-object dbx) 
                                             (setq dbx nil) 
                                         ) 
                                         (progn 
                                             (setq notopen (cons x notopen)) 
                                             (vlax-release-object dbx) 
                                             (setq dbx nil) 
                                         ) 
                                     ) 
                                 ) 
                              ;(cdr fls) 
                                fls 
                            ) 
                            (if        dbx 
                                (vlax-release-object dbx) 
                            ) 
                            (if        notopen 
                                (progn 
                                    (princ 
                                        "\n======================================================================" 
                                    ) 
                                    (princ 
                                        "\n以下为未修改文件，可能文件已打开或者为高版本图形或者未找到修改之属性!" 
                                    ) 
                                    (princ 
                                        "\n======================================================================" 
                                    ) 
                                    (mapcar 
                                        '(lambda (x) 
                                             (princ (strcat "\n" x " Not Changed!")) 
                                         ) 
                                        notopen 
                                    ) 
                                ) 
                            ) 
                        ) 
                        (princ "\n没有输入或用户取消!") 
                    ) 
                ) 
                (princ "\n没有选择文件或不能批量修改!") 
            ) 
        ) 
    ) 
    (setq *error* olderr) 
    (princ) 
)

对话框

dwgatt : dialog {
label = "图签属性修改作者: eachy[晓东空间]";
: column {
fixed_width = true;
: boxed_column {
label = "图纸属性";
: row {
: edit_box {
label = "日　期";
key = "date";
}
: edit_box {
label = "版　次";
key = "vers";
}
}
: row {
: edit_box {
label = "合同号";
key = "Hname";
}
: edit_box {
label = "图　别";
key = "Tname";
}
}
}
: boxed_column {
label = "项目信息";
width = 50;
: edit_box {
label = "工程名称 ";
key = "Pname";
width = 30;
}
: edit_box {
label = "建设单位1";
key = "cname1";
width = 30;
}
: edit_box {
label = "建设单位2";
key = "cname2";
width = 30;
}
}
}
ok_cancel;
}}

dwgatt : dialog { 
label = "图签属性修改  作者: eachy[晓东空间]"; 
: column { 
 fixed_width = true; 
  : boxed_column { 
    label = "图纸属性"; 
    : row { 
      : edit_box { 
        label = "日　期"; 
        key = "date"; 
        } 
      : edit_box { 
        label = "版　次"; 
        key = "vers"; 
        } 
      } 
    : row { 
      : edit_box { 
        label = "合同号"; 
        key = "Hname"; 
        } 
      : edit_box { 
        label = "图　别"; 
        key = "Tname"; 
        } 
      } 
    } 
  : boxed_column { 
    label = "项目信息"; 
    width = 50; 
    : edit_box { 
      label = "工程名称  "; 
      key = "Pname"; 
      width = 30; 
      } 
    : edit_box { 
      label = "建设单位1"; 
      key = "cname1"; 
      width = 30; 
      } 
    : edit_box { 
      label = "建设单位2"; 
      key = "cname2"; 
      width = 30; 
      } 
    } 
  } 
 ok_cancel; 
}}

声明:运行本程序时请对原图做备份,以避免程序运行错误时将原图遭破坏的严重后查!!!

szkevin · 发表于 2006-4-9 22:48:35

图形选择界面

szkevin · 发表于 2006-4-9 22:49:55

属性输入界面

szkevin · 发表于 2006-4-10 18:27:40

程序下载

ENGNIEER · 发表于 2006-4-11 16:30:18

下载不了附件，请再上传！

szkevin · 发表于 2006-4-15 00:18:33

本程序已在2006年4月15日做了更新,并做了严格的测试,请重新下载,以前版本有可能不稳定选成文件损坏.

lemonx · 发表于 2006-4-15 07:04:00

复杂了
图签应该用参照，一改皆改

hero_wch · 发表于 2006-4-15 18:56:48

最初由 lemonx 发布
[B]复杂了
图签应该用参照，一改皆改 [/B]

同意，我就是这样做地

madeinchina · 发表于 2006-4-19 23:02:05

很好的程序，下不了楼主快点检查，能否发到bamboo79@tom.com给我

云飞日月 · 发表于 2006-4-24 22:40:50

为什么不能下载

ngmxf · 发表于 2009-9-4 14:45:47

怎么不能下载呢

cseryaobaoku · 发表于 2015-1-22 17:54:17

好好学习学习

zzwq2008 · 发表于 2016-6-14 00:22:16

学习学习谢谢分享

1028882406@qq.c · 发表于 2017-4-27 00:08:35

谢谢楼主，好功能

qq1254582201 · 发表于 2017-6-2 15:17:58

lemonx 发表于 2006-4-15 07:04

不错不错，能简单就简单，代码虽好，不如靠谱的来的实在。。。

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

[分享]：批量修改图签程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子