[试用]：【 图纸归档 】程序（对话框版）

xyp1964

加载程序：tzgd(图纸归档)
运行命令：tzgd
文件上载有问题！可到网络U盘或QQ群24942984下载[/COLOR]
http://xyp1964.ys168.com“CAD程序下载02 ”内

xyp1964

效果1：

brainstorm

我以前写的一个，不如你的程序方便
;;--------以下为秋枫的获取文件目录程序--------------
(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
  )
)
;;-------秋枫的获取文件目录程序结束--------------
;;;;;建立图层，并设置为当前图层
(defun zgx-crtlayer (lyr_name lyr_color / lay1)
(setq lay1 (tblsearch "layer" lyr_name))
(if (null lay1)
(command ".layer" "n" lyr_name "s" lyr_name "c" lyr_color lyr_name  "" )
)
(command ".layer" "on" lyr_name "")
(setvar "clayer" lyr_name)
)
(defun c:bblk5 (/ dwglist dwgname i k  curlyr lay1 os_mode lyr_name lyr_color lyr_name dwgsuffixold)
(princ "\n根据公司电子版文件归档要求编制，用于文件自动归档;图纸中有重名文件，程序会出错。")
(setq c_date (rtos (getvar "cdate") 2 7))
(setq dwgpath (qf_getfolder "选择文件保存的目录:"))
(if (= (strlen dwgpath) 3)
    (setq dwgpath (substr dwgpath 1 2))
)
(zgx-crtlayer c_date "210")
(if dwgsuffix
    (setq dwgsuffix dwgsuffix)
    (setq dwgsuffix "T02005")
)
(setq dwgsuffixold (getstring (strcat "\n请输入图纸编号关键字<默认:" dwgsuffix ">:")))
(if (= dwgsuffixold "")
    (setq dwgsuffix dwgsuffix)
    (setq dwgsuffix dwgsuffixold)
)
(setq dwgsuffix (strcase dwgsuffix))
(prompt "\n请选择图纸名称:")
(setq dwgname (ssget (list '(-4 . "<or")
                                '(-4 . "<and")
                                '(0 . "text") (cons 1 (strcat dwgsuffix "*"))
                                '(-4 . "and>")
                                '(-4 . "<and")
                                '(0 . "ATTDEF") (cons 2 (strcat dwgsuffix "*"))
                                '(-4 . "and>")
                           '(-4 . "or>")
                                                
                      )
              )
)
(setq i 0)
(repeat (sslength dwgname)
        (setq ent (ssname dwgname i))
        (setq endata (entget ent))
        (setq endata (subst (cons 8 c_date) (assoc 8 endata) endata))
        (entmod endata)
        (setq i (+ i 1))
)
(setq dwglist '("dwglist"))
(setq i 1)
(prompt (strcat "\n请选择第" (rtos i 2 0) "张图纸(每次选择一张图纸，选择图纸总张数应与图纸名称数量相等):"))
(setq dwg (ssget))
(setq dwgname (ssget "p" (list (cons 8  c_date) ))) ;;;'((-3 ("dwgname")))
(if (= (cdr (assoc 0 (entget (ssname dwgname 0)))) "TEXT")
(setq dwgname (cdr (assoc 1 (entget (ssname dwgname 0)))))
(setq dwgname (cdr (assoc 2 (entget (ssname dwgname 0)))))
)
(setq dwglist (append dwglist (list (cons dwgname dwg))))
(while dwg
       (setq i (+ i 1))
       (prompt (strcat "\n请选择第" (rtos i 2 0 ) "张图纸(每次选择一张图纸,右键退出):"))
       (setq dwg (ssget))
       (setq dwgname (ssget "p" (list (cons 8  c_date) )))  ;;;'(-3 ("dwgname"))
       (if (= (cdr (assoc 0 (entget (ssname dwgname 0)))) "TEXT")
       (setq dwgname (cdr (assoc 1 (entget (ssname dwgname 0)))))
       (setq dwgname (cdr (assoc 2 (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 dwgpath "\\" (car (nth i dwglist)) ) "" "0,0" (cdr (nth i dwglist)) "")
      (setq i (+ i 1))
      )
)
(setvar "clayer" curlyr)
(setvar "osmode" os_mode)
(alert (strcat "\n共" (rtos (- i 1) 2 0) "个文件已经保存在" dwgpath "\\. "))
(princ)
)
;;;end mark
(princ "\n以bblk5启动程序")

xyp1964

终于恢复正常了！标注信息：

dwg001

最初由 brainstorm 发布
[B]我以前写的一个，不如你的程序方便
;;--------以下为秋枫的获取文件目录程序--------------
(defun qf_getFolder (msg / WinShell shFolder path catchit)
  (vl-load-com)
  (setq winshell (vlax-create-objec... [/B]

错误 : 输入的点对中含有多余的 cdrs