[分享]：图纸自动归档程序，请高手帮忙修改

brainstorm

;程序有两个缺点
;1.不能通过对话框选择文件目录
;2.如果有重名文件程序会出错
;请高手给完善以下，程序主要用于电子版文件自动归档
(defun c:bblk (/ dwglist dwgname i k )
(princ "\n根据公司电子版文件归档要求编制，用于文件自动归档，输出文件在d:\下。天辰公司")
(regapp "dwgname")
(setq newlist
(list -3
(list "dwgname" (cons 1000 "dwgname"))
)
)
(prompt "\n请选择图纸名称")
(setq dwgsuffix (getstring "\n请输入图纸编号关键字:"))
(while (= dwgsuffix "")
(prompt "\n图纸编号关键字不能为空:")
(setq dwgsuffix (getstring "\n请输入图纸编号关键字:"))
)
(setq dwgsuffix (strcase dwgsuffix))

(setq dwgname (ssget (list '(0 . "text") (cons 1 (strcat dwgsuffix "*")))))
(setq i 0)
(repeat (sslength dwgname)
(setq ent (ssname dwgname i))
(setq endata (entget ent))
(setq endata (append endata (list newlist)))
(entmod endata)
(setq i (+ i 1))
)
(setq dwglist '(dwglist))
(setq i 1)
(prompt (strcat "\n请选择第" (rtos i ) "张图纸(每次选择一张图纸):"))
(setq dwg (ssget))
(setq dwgname (ssget "p" '((-3 ("dwgname")))))
(setq dwgname (cdr (assoc 1 (entget (ssname dwgname 0)))))
(setq dwglist (append dwglist (list (cons dwgname dwg))))
(while dwg
(setq i (+ i 1))
(prompt (strcat "\n请选择第" (rtos i ) "张图纸(每次选择一张图纸,右键退出):"))
(setq dwg (ssget))
(setq dwgname (ssget "p" '((-3 ("dwgname")))))
(setq dwgname (cdr (assoc 1 (entget (ssname dwgname 0)))))
(setq dwglist (append dwglist (list (cons dwgname dwg))))
)
(setq k (length dwglist))
(setq i 1)
(while (< i (- k 1))
(repeat (- k 2)
(command ".wblock" (strcat "d:/" (car (nth i dwglist)) ) "" "0,0" (cdr (nth i dwglist)) "")
(command "oops")
(setq i (+ i 1))
)
)



);;;end mark
(princ "\n以bblk启动程序")

大清

化院的，你好！

brainstorm

你好，在何处工作

大清

在南开区！我的qq：85363241
常交流！你单位我在哪做过几个月，属于外借！

brainstorm

好，常常联络，qq:19468944

秋枫

》》不能通过对话框选择文件目录

提供一个函数，我以前设计的；首发于明经通道，适用于AutoCAD 200X
http://www.mjtd.com/Html/Functions/FunVLISP/5520051105224632.htm

;; 本代码仅提供作为应用上的参考, 而未声明或隐含任何保证; 对于任何特殊
;; 用途之适应性, 以及商业销售所隐含作出的保证, 在此一概予以否认.
;; ==================================================================
;; 作者：秋枫，参考了灯火的VBA程序
;; 用法：(qf_getFolder msg)
;; 例子：(qf_getFolder "选择文件夹:")
;; 返回值：字符串，文件夹路径，如果点了cancel, 返回nil


(defun qf_getFolder (msg / WinShell shFolder path catchit)
  (vl-load-com)
  (setq winshell (vlax-create-object "Shell.Application"))
  (setq shFolder (vlax-invoke-method WinShell 'BrowseForFolder 0 msg 1))
  (setq
    catchit (vl-catch-all-apply
       '(lambda ()
   (setq shFolder (vlax-get-property shFolder 'self))
   (setq path (vlax-get-property shFolder 'path))
        )
     )
  )
  (if (vl-catch-all-error-p catchit)
    nil
    path
  )
)

brainstorm

谢谢秋枫大侠的指点