谁有空修改下langjs大师的目录提取的程序！

spp_wall · 发表于 2014-10-26 13:31

在论坛找到的langjs大师的目录提取的程序！感觉比较复杂，我自己的图框比较简单，想改成适合自己图框的程序，但是改了下发现不行，功力有限，麻烦大家帮帮忙！

附上测试的文件和结果，还有langjs大师的程序！

vectra · 发表于 2014-10-26 13:31

本帖最后由 vectra 于 2014-10-26 19:51 编辑

重写了个
在要输出的目录中创建一个新dwg文件，运行extract，提同目录下所有其它dwg文件中的目录信息到“目录.csv”文件中。

;;;(defun extract-block-attribs (name / n obj rt ss tmp)
;;; (if (setq ss (ssget "X" (list '(0 . "INSERT") (cons 2 name))))
;;; (repeat (setq n (sslength ss))
;;; (setq obj (vlax-ename->vla-object (ssname ss (setq n (1- n)))))
;;;
;;; (foreach att (vlax-safearray->list
;;; (vlax-variant-value (vla-getattributes obj))
;;; )
;;; (setq tmp (cons (cons (vla-get-tagstring att)
;;; (vla-get-textstring att)
;;; )
;;; tmp
;;; )
;;; )
;;; )
;;; (setq rt (cons tmp rt)
;;; tmp nil
;;; )
;;; )
;;; )
;;; rt
;;;)
;; (extract-block-attribs "KX-目录属性块")
(defun get-dwgfilenames (/ e path)
(setq path (vl-filename-directory (getvar "DWGPREFIX")))
(mapcar '(lambda (e) (strcat path "\\" e))
(vl-directory-files path "*.dwg" 1)
)
)
;;;
(defun extract-block-attribs2 (doc name / rt tmp)
(vlax-for layout (vla-get-layouts doc)
(vlax-for block (vla-get-block layout)
(if (and
(= (vla-get-objectname block) "AcDbBlockReference")
(= (vla-get-name block) name)
)
(progn
(foreach att (vlax-safearray->list
(vlax-variant-value (vla-getattributes block))
)
(setq tmp (cons (cons (vla-get-tagstring att)
(vla-get-textstring att)
)
tmp
)
)
)
(setq rt (cons tmp rt)
tmp nil
)
)
)
)
)
rt
)
;;(extract-block-attribs2 (vla-get-activedocument (vlax-get-acad-object)) *title-block-name*)
(defun extract-file-attribs (filename / doc rt)
(if (/= (strcase filename)
(strcase
(strcat (getvar "DWGPREFIX") (getvar "DWGNAME"))
)
)
(progn
(setq doc (vla-open (vla-get-documents (vlax-get-acad-object))
filename
)
)
(setq rt (vl-bb-ref '*extracted-attribs*)
rt (cons (cons (strcase filename t)
(extract-block-attribs2 doc *title-block-name*)
)
rt
)
)
(vl-bb-set '*extracted-attribs* rt)
(vla-close doc)
)
)
)
;; (extract-file-attribs (getfiled "打开文件" (getvar "dwgprefix") "dwg" 0))
;; 该函数不能在VLIDE中运行，会导致CAD崩溃
(defun concrate (lst)
(strcat (car lst)
(apply 'strcat
(mapcar '(lambda (e) (strcat "," e)) (cdr lst))
)
)
)
;; (concrate '("图号" "图名" "总页码"))
;; "图号,图名,总页码"
(defun write-content (/ e file filename ml row mli)
(setq filename (strcat (getvar "dwgprefix") "目录.csv"))
(setq file (open filename "w"))
(write-line (concrate *extract-tag*) file)
(foreach ml (mapcar 'cdr (vl-bb-ref '*extracted-attribs*))
(foreach mli ml
(setq row (mapcar '(lambda (e) (cdr (assoc e mli)))
*extract-tag*
)
)
(write-line
(strcat (car row)
(apply 'strcat
(mapcar '(lambda (e) (strcat "," e)) (cdr row))
)
)
file
)
)
)
(close file)
(startapp "notepad" filename)
)
;;
(defun c:extract ()
(vl-bb-set '*extracted-attribs* nil)
(mapcar 'extract-file-attribs (get-dwgfilenames))
(write-content)
(princ)
)
;;
(setq *title-block-name* "KX-目录属性块"
*extract-tag* '("图号" "图名" "总页码")
)

;;;(defun extract-block-attribs (name / n obj rt ss tmp) 
;;;  (if (setq ss (ssget "X" (list '(0 . "INSERT") (cons 2 name)))) 
;;;    (repeat (setq n (sslength ss)) 
;;;      (setq obj (vlax-ename->vla-object (ssname ss (setq n (1- n))))) 
;;; 
;;;      (foreach att (vlax-safearray->list 
;;;                     (vlax-variant-value (vla-getattributes obj)) 
;;;                   ) 
;;;        (setq tmp (cons        (cons (vla-get-tagstring att) 
;;;                              (vla-get-textstring att) 
;;;                        ) 
;;;                        tmp 
;;;                  ) 
;;;        ) 
;;;      ) 
;;;      (setq rt        (cons tmp rt) 
;;;            tmp        nil 
;;;      ) 
;;;    ) 
;;;  ) 
;;;  rt 
;;;) 
;; (extract-block-attribs "KX-目录属性块") 
 
 
(defun get-dwgfilenames        (/ e path) 
  (setq path (vl-filename-directory (getvar "DWGPREFIX"))) 
  (mapcar '(lambda (e) (strcat path "\\" e)) 
          (vl-directory-files path "*.dwg" 1) 
  ) 
) 
;;; 
 
 
(defun extract-block-attribs2 (doc name / rt tmp) 
  (vlax-for layout (vla-get-layouts doc) 
    (vlax-for block (vla-get-block layout) 
      (if (and 
            (= (vla-get-objectname block) "AcDbBlockReference") 
            (= (vla-get-name block) name) 
          ) 
        (progn 
          (foreach att (vlax-safearray->list 
                         (vlax-variant-value (vla-getattributes block)) 
                       ) 
            (setq tmp (cons (cons (vla-get-tagstring att) 
                                  (vla-get-textstring att) 
                            ) 
                            tmp 
                      ) 
            ) 
          ) 
          (setq        rt  (cons tmp rt) 
                tmp nil 
          ) 
        ) 
      ) 
    ) 
  ) 
  rt 
) 
;;(extract-block-attribs2 (vla-get-activedocument (vlax-get-acad-object)) *title-block-name*) 
 
 
(defun extract-file-attribs (filename / doc rt) 
  (if (/= (strcase filename) 
          (strcase 
            (strcat (getvar "DWGPREFIX") (getvar "DWGNAME")) 
          ) 
      ) 
    (progn 
      (setq doc        (vla-open (vla-get-documents (vlax-get-acad-object)) 
                          filename 
                ) 
      ) 
 
      (setq rt (vl-bb-ref '*extracted-attribs*) 
            rt (cons (cons (strcase filename t) 
                           (extract-block-attribs2 doc *title-block-name*) 
                     ) 
                     rt 
               ) 
      ) 
      (vl-bb-set '*extracted-attribs* rt) 
 
      (vla-close doc) 
    ) 
  ) 
) 
;; (extract-file-attribs (getfiled "打开文件" (getvar "dwgprefix") "dwg" 0)) 
;; 该函数不能在VLIDE中运行，会导致CAD崩溃 
 
 
(defun concrate        (lst) 
  (strcat (car lst) 
          (apply 'strcat 
                 (mapcar '(lambda (e) (strcat "," e)) (cdr lst)) 
          ) 
  ) 
) 
;; (concrate '("图号" "图名" "总页码")) 
;; "图号,图名,总页码" 
 
 
(defun write-content (/ e file filename ml row mli) 
  (setq filename (strcat (getvar "dwgprefix") "目录.csv")) 
  (setq file (open filename "w")) 
 
  (write-line (concrate *extract-tag*) file) 
 
  (foreach ml (mapcar 'cdr (vl-bb-ref '*extracted-attribs*)) 
    (foreach mli ml 
      (setq row        (mapcar        '(lambda (e) (cdr (assoc e mli))) 
                        *extract-tag* 
                ) 
      ) 
      (write-line 
        (strcat        (car row) 
                (apply 'strcat 
                       (mapcar '(lambda (e) (strcat "," e)) (cdr row)) 
                ) 
        ) 
        file 
      ) 
    ) 
  ) 
 
  (close file) 
  (startapp "notepad" filename) 
) 
;; 
 
(defun c:extract () 
  (vl-bb-set '*extracted-attribs* nil) 
  (mapcar 'extract-file-attribs (get-dwgfilenames)) 
 
  (write-content) 
 
  (princ) 
) 
;; 
 
(setq *title-block-name* "KX-目录属性块" 
      *extract-tag*         '("图号" "图名" "总页码") 
)

spp_wall · 发表于 2014-10-26 19:27

该出手就出手！！！！！！！

spp_wall · 发表于 2014-10-26 21:22

vectra 发表于 2014-10-26 19:49
重写了个
在要输出的目录中创建一个新dwg文件，运行extract，提同目录下所有其它dwg文件中的目录信息到“目 ...

可以了！还有几个问题，如果有空的话可以帮我完善下！
1：如果还有其他属性块：比如 KX-pm；KX-zm这样的属性块，能不能也一起提取“图号”“图名”“总页码”到一个csv.
2：排序好像是大到小，能否变成从小到大，不过这问题不大，点下EXL排序也是一部！
3：能否实现langjs大师那样的，读取一个文件夹的文件，而不用新建一个dwg！

有空的话完善下第1点，第2，3不解决也没关系！谢谢

vectra · 发表于 2014-10-26 23:18

1～3已修改，现在可以从任意dwg文件中运行extract命令，然后选择要处理目录里的一个文件，则该目录里的所有文件均会处理。

要提取的块名称以及要输出的属性可以修改文件最后两个行那两个变量

spp_wall · 发表于 2014-10-27 08:19

本帖最后由 spp_wall 于 2014-10-27 08:34 编辑

vectra 发表于 2014-10-26 23:18
1～3已修改，现在可以从任意dwg文件中运行extract命令，然后选择要处理目录里的一个文件，则该目录里的所有 ...

还有一个比较大得问题，昨天没发现，能否删掉重复项，图名一样的就保留一个

图号,图名,总页码
图号1,图名1,总页码1
图号2,图名2,总页码2
图号3,图名3,总页码3
图号3,图名3,总页码3
图号3,图名3,总页码3

spp_wall · 发表于 2014-10-27 14:46

vectra 发表于 2014-10-26 23:18
1～3已修改，现在可以从任意dwg文件中运行extract命令，然后选择要处理目录里的一个文件，则该目录里的所有 ...

有时是图名和图号总页码都是一样的因为有时候一个图名或者一个图号会有很多页！
所以不重复最好

spp_wall · 发表于 2014-10-27 17:27

后续用exl数据-->筛选排序-->消除重复项
处理下就可以了！

caogis · 发表于 2015-9-6 22:22

这么好的程序！如能加入时间就好了

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

[已解答] 谁有空修改下langjs大师的目录提取的程序！

最佳答案

本帖子中包含更多资源

点评

浏览过的版块