[求助]：一个导出图形的线，文本，图块，图层，文字样式的程序问题

lt_zzy · 发表于 2005-12-5 13:02:24

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

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

×

[FONT=courier new]
(defun c:batchblit(/ filestring f curdoc activedoc)
(defun layerprint(doc / layersel layerobj layername f)
(setq layersel (vla-get-layers doc))
(setq filename (vla-get-name doc))
(setq f (open "d:\\output\\layers.txt" "a"))
(write-line filename f)
(vlax-for layerObj layersel
(setq layername (vla-get-name layerObj))
(write-line layername f)
)
(close f)
(princ "\n图层的列表信息已写入到 D:\\output\\layers.txt")
(princ)
)
(defun textstyleprint(doc / textstylesel textstyleobj textstylename f)
(setq filename (vla-get-name doc))
(setq textstylesel (vla-get-textstyles doc))
(setq f (open "d:\\output\\textstyles.txt" "a"))
(write-line filename f)
(vlax-for textstyleObj textstylesel
(setq textstylename (vla-get-name textstyleObj))
(write-line textstylename f)
)
(close f)
(princ "\n文字样式的列表信息已写入到 D:\\output\\textstyles.txt")
(princ)
)
(defun blockprint(doc / blocksel blockobj blockname i f)
(setq filename (vla-get-name doc))
(setq blocksel (vla-get-blocks doc) i 0)
(vlax-for blockObj blocksel
(setq blockname (vla-get-name blockObj))
(if (/= (substr blockname 1 1) "*")
(progn
(setq i (1+ i))
)
)
)
(if (/= i 0)
(progn
(setq f (open "d:\\output\\blocks.txt" "a"))
(write-line filename f)
(vlax-for blockObj blocksel
(setq blockname (vla-get-name blockObj))
(if (/= (substr blockname 1 1) "*")
(write-line blockname f)
)
)
(close f)
(princ "\n文字样式的列表信息已写入到 D:\\output\\blocks.txt")
)
(princ "\n******图中不存在有名图块! ******")
)
(princ)
)
(defun information(doc / filename linenumber blocknumber textnumber linesel blocksel
textsel f)
(setq filename (vla-get-name doc))
(vla-activate doc)
(setq linesel (ssget "X" '((0 . "*LINE"))))
(setq blocksel (ssget "X" '((0 . "INSERT"))))
(setq textsel (ssget "X" '((0 . "*TEXT"))))
(if (/= linesel nil)
(setq linenumber (sslength linesel))
(setq linenumber 0)
)
(if (/= blocksel nil)
(setq blocknumber (sslength blocksel))
(setq blocknumber 0)
)
(if (/= textsel nil)
(setq textnumber (sslength textsel))
(setq textnumber 0)
)
(setq f (open "d:\\output\\information.txt" "a"))
(write-line (strcat filename
" "
(itoa linenumber)
" "
(itoa blocknumber)
" "
(itoa textnumber)
)
f)
(close f)
(princ "\n线、图块、文字的数量信息已写入到 D:\\output\\information.txt")
(princ)
)
(vl-load-com)
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument AcadObject)
)
(setq Documents (vla-get-Documents (vla-get-Application AcadDocument)))
(setq f (open "d:\\output\\dwgs.txt" "r"))
(if (null f)
(alert "d:\\output\\dwgs.txt文件不存在!\n请建立!")
(progn
(while (setq filestring (read-line f))
(setq activedoc (vla-open Documents filestring))
(if (/= activedoc nil)
(progn
(layerprint activedoc)
(information activedoc)
(blockprint activedoc)
(textstyleprint activedoc)
(vla-close activedoc)
)
)
)
(close f)
)
)
(princ)
)
[/FONT]

[FONT=courier new] 
(defun c:batchblit(/ filestring f curdoc activedoc) 
   (defun layerprint(doc / layersel layerobj layername f) 
     (setq layersel (vla-get-layers doc)) 
     (setq filename (vla-get-name doc)) 
     (setq f (open "d:\\output\\layers.txt" "a")) 
     (write-line filename f) 
     (vlax-for layerObj layersel 
        (setq layername (vla-get-name layerObj)) 
        (write-line layername f) 
     ) 
     (close f) 
     (princ "\n图层的列表信息已写入到 D:\\output\\layers.txt") 
     (princ) 
    ) 
 
   (defun textstyleprint(doc / textstylesel textstyleobj textstylename f) 
     (setq filename (vla-get-name doc)) 
     (setq textstylesel (vla-get-textstyles doc)) 
     (setq f (open "d:\\output\\textstyles.txt" "a")) 
     (write-line filename f) 
     (vlax-for textstyleObj textstylesel 
        (setq textstylename (vla-get-name textstyleObj)) 
        (write-line textstylename f) 
     ) 
     (close f) 
     (princ "\n文字样式的列表信息已写入到 D:\\output\\textstyles.txt") 
     (princ) 
    ) 
 
   (defun blockprint(doc / blocksel blockobj blockname i f) 
     (setq filename (vla-get-name doc)) 
     (setq blocksel (vla-get-blocks doc) i 0) 
     (vlax-for blockObj blocksel 
       (setq blockname (vla-get-name blockObj)) 
       (if (/= (substr blockname 1 1) "*") 
         (progn 
           (setq i (1+ i)) 
         ) 
       ) 
     ) 
     (if (/= i 0) 
       (progn 
          (setq f (open "d:\\output\\blocks.txt" "a")) 
          (write-line filename f) 
          (vlax-for blockObj blocksel 
             (setq blockname (vla-get-name blockObj)) 
             (if (/= (substr blockname 1 1) "*") 
                (write-line blockname f) 
             ) 
          ) 
          (close f) 
          (princ "\n文字样式的列表信息已写入到 D:\\output\\blocks.txt") 
       ) 
       (princ "\n******图中不存在有名图块! ******") 
     ) 
     (princ) 
    ) 
 
   (defun information(doc / filename linenumber blocknumber textnumber linesel blocksel 
 
textsel f) 
     (setq filename (vla-get-name doc)) 
     (vla-activate doc) 
     (setq linesel (ssget "X" '((0 . "*LINE")))) 
     (setq blocksel (ssget "X" '((0 . "INSERT")))) 
     (setq textsel (ssget "X" '((0 . "*TEXT")))) 
     (if (/= linesel nil) 
         (setq linenumber (sslength linesel)) 
         (setq linenumber 0) 
     ) 
     (if (/= blocksel nil) 
         (setq blocknumber (sslength blocksel)) 
         (setq blocknumber 0) 
     ) 
     (if (/= textsel nil) 
         (setq textnumber (sslength textsel)) 
         (setq textnumber 0) 
     ) 
     (setq f (open "d:\\output\\information.txt" "a")) 
     (write-line (strcat filename 
                         "         " 
                         (itoa linenumber) 
                         "         " 
                         (itoa blocknumber) 
                         "         " 
                         (itoa textnumber) 
                 ) 
                         f) 
     (close f) 
     (princ "\n线、图块、文字的数量信息已写入到 D:\\output\\information.txt") 
     (princ) 
    ) 
   
  (vl-load-com) 
  (setq AcadObject (vlax-get-acad-object) 
        AcadDocument (vla-get-ActiveDocument AcadObject) 
  ) 
  (setq Documents (vla-get-Documents (vla-get-Application AcadDocument))) 
  (setq f (open "d:\\output\\dwgs.txt" "r")) 
  (if (null f) 
     (alert "d:\\output\\dwgs.txt文件不存在!\n请建立!") 
     (progn 
        (while (setq filestring (read-line f)) 
           (setq activedoc (vla-open Documents filestring)) 
           (if (/= activedoc nil) 
              (progn 
                 (layerprint activedoc) 
                 (information activedoc) 
                 (blockprint activedoc) 
                 (textstyleprint activedoc) 
                 (vla-close activedoc) 
              ) 
           ) 
        ) 
        (close f) 
     ) 
  ) 
  (princ) 
) 
  [/FONT]

这个程序的目的是将存在的文件打开，并将新打开的文件的图层，图块(种类)，文字样式和线，文本，块(个数)的数量信息分别导入到相关的文件中。
导出的线，文本，块的数量信息，是当前图形文件的，而不是新打开的文件的；图层，图块，文字样式信息也不完全相符，特别是文字样式信息，有时候出现前一个图形文件的某个文字样式信息，不知道问题出在什么地方，请高手帮忙给调一下。谢谢！！！

snoopychen · 发表于 2005-12-6 08:42:47

不大会写这种vb类型的lisp
胡弄了一个小时，才算搞定
程序如下
用的时候，dwgs.txt里面应该是类似k:\seven2.dwg的字样
版主说的问题主要出现在information这一段，其他的块，层，文字式样都
是没有问题的。
原问题的出错的地方在于其information段与layerprint等段不一样
它采用了(setq linesel (ssget "X" '((0 . "LINE"))))这种语句
而其他的子程序采用的是 (setq layersel (vla-get-layers doc))
   (vlax-for layerObj layersel）
   这样子的VL语句，因此information段出现了在当前图形内进行找线
   找文字的做法。
   现在我主要是修改成为(setq mSpace (vla-get-ModelSpace doc))
   (VLAX-FOR entry mSpace）
   的VL写法，这样子就不会导致文件空间的混乱
   试了一下，大概是没有问题的。
   不知道在楼主那里如何

(defun c:batchblit(/ filestring f curdoc activedoc)
(defun layerprint(doc / layersel layerobj layername f)
(setq layersel (vla-get-layers doc))
(setq filename (vla-get-name doc))
(setq f (open "d:\\output\\layers.txt" "a"))
(write-line filename f)
(vlax-for layerObj layersel
(setq layername (vla-get-name layerObj))
(write-line layername f)
)
(close f)
(princ "\n图层的列表信息已写入到 D:\\output\\layers.txt")
(princ)
)
(defun textstyleprint(doc / textstylesel textstyleobj textstylename f)
(setq filename (vla-get-name doc))
(setq textstylesel (vla-get-textstyles doc))
(setq f (open "d:\\output\\textstyles.txt" "a"))
(write-line filename f)
(vlax-for textstyleObj textstylesel
(setq textstylename (vla-get-name textstyleObj))
(write-line textstylename f)
)
(close f)
(princ "\n文字样式的列表信息已写入到 D:\\output\\textstyles.txt")
(princ)
)
(defun blockprint(doc / blocksel blockobj blockname i f)
(setq filename (vla-get-name doc))
(setq blocksel (vla-get-blocks doc) i 0)
(vlax-for blockObj blocksel
(setq blockname (vla-get-name blockObj))
(if (/= (substr blockname 1 1) "*")
(progn
(setq i (1+ i))
)
)
)
(if (/= i 0)
(progn
(setq f (open "d:\\output\\blocks.txt" "a"))
(write-line filename f)
(vlax-for blockObj blocksel
(setq blockname (vla-get-name blockObj))
(if (/= (substr blockname 1 1) "*")
(write-line blockname f)
)
)
(close f)
(princ "\n文字样式的列表信息已写入到 D:\\output\\blocks.txt")
)
(princ "\n******图中不存在有名图块! ******")
)
(princ)
)
(defun information(doc / filename linenumber blocknumber textnumber linesel blocksel
textsel f)
(setq filename (vla-get-name doc))
;(vla-activate doc)
(setq mSpace (vla-get-ModelSpace doc))
(setq i1 0 i2 0 i3 0)
(VLAX-FOR entry mSpace
(setq objName (vla-get-ObjectName entry))
(if (wcmatch objname "*ine") (setq i1 (1+ i1)))
(if (wcmatch objname "*Text") (setq i2 (1+ i2)))
(if (wcmatch objname "*Block*") (setq i3 (1+ i3)))
)
(princ)
(setq f (open "d:\\output\\information.txt" "a"))
(write-line (strcat filename
" "
(itoa i1)
" "
(itoa i2)
" "
(itoa i3)
)
f)
(close f)
(princ "\n线、图块、文字的数量信息已写入到 D:\\output\\information.txt")
(princ)
)
(vl-load-com)
(setq AcadObject (vlax-get-acad-object)
AcadDocument (vla-get-ActiveDocument AcadObject)
)
(setq Documents (vla-get-Documents (vla-get-Application AcadDocument)))
(setq f (open "d:\\output\\dwgs.txt" "r"))
(if (null f)
(alert "d:\\output\\dwgs.txt文件不存在!\n请建立!")
(progn
(while (setq filestring (read-line f))
(setq activedoc (vla-open Documents filestring))
(if (/= activedoc nil)
(progn
(layerprint activedoc)
(information activedoc)
(blockprint activedoc)
(textstyleprint activedoc)
(vla-close activedoc)
)
)
)
(close f)
)
)
(princ)
)

(defun c:batchblit(/ filestring f curdoc activedoc) 
   (defun layerprint(doc / layersel layerobj layername f) 
     (setq layersel (vla-get-layers doc)) 
     (setq filename (vla-get-name doc)) 
     (setq f (open "d:\\output\\layers.txt" "a")) 
     (write-line filename f) 
     (vlax-for layerObj layersel 
        (setq layername (vla-get-name layerObj)) 
        (write-line layername f) 
     ) 
     (close f) 
     (princ "\n图层的列表信息已写入到 D:\\output\\layers.txt") 
     (princ) 
    ) 
 
   (defun textstyleprint(doc / textstylesel textstyleobj textstylename f) 
     (setq filename (vla-get-name doc)) 
     (setq textstylesel (vla-get-textstyles doc)) 
     (setq f (open "d:\\output\\textstyles.txt" "a")) 
     (write-line filename f) 
     (vlax-for textstyleObj textstylesel 
        (setq textstylename (vla-get-name textstyleObj)) 
        (write-line textstylename f) 
     ) 
     (close f) 
     (princ "\n文字样式的列表信息已写入到 D:\\output\\textstyles.txt") 
     (princ) 
    ) 
 
   (defun blockprint(doc / blocksel blockobj blockname i f) 
     (setq filename (vla-get-name doc)) 
     (setq blocksel (vla-get-blocks doc) i 0) 
     (vlax-for blockObj blocksel 
       (setq blockname (vla-get-name blockObj)) 
       (if (/= (substr blockname 1 1) "*") 
         (progn 
           (setq i (1+ i)) 
         ) 
       ) 
     ) 
     (if (/= i 0) 
       (progn 
          (setq f (open "d:\\output\\blocks.txt" "a")) 
          (write-line filename f) 
          (vlax-for blockObj blocksel 
             (setq blockname (vla-get-name blockObj)) 
             (if (/= (substr blockname 1 1) "*") 
                (write-line blockname f) 
             ) 
          ) 
          (close f) 
          (princ "\n文字样式的列表信息已写入到 D:\\output\\blocks.txt") 
       ) 
       (princ "\n******图中不存在有名图块! ******") 
     ) 
     (princ) 
    ) 
 
   (defun information(doc / filename linenumber blocknumber textnumber linesel blocksel 
 
textsel f) 
     (setq filename (vla-get-name doc)) 
     ;(vla-activate doc) 
     (setq mSpace (vla-get-ModelSpace doc)) 
     (setq i1 0 i2 0 i3 0) 
     (VLAX-FOR entry mSpace 
    (setq objName (vla-get-ObjectName entry)) 
(if (wcmatch objname "*ine") (setq i1 (1+ i1))) 
(if (wcmatch objname "*Text") (setq i2 (1+ i2))) 
(if (wcmatch objname "*Block*") (setq i3 (1+ i3))) 
  ) 
  (princ) 
     (setq f (open "d:\\output\\information.txt" "a")) 
     (write-line (strcat filename 
                         "         " 
                         (itoa i1) 
                         "         " 
                         (itoa i2) 
                         "         " 
                         (itoa i3) 
                 ) 
                         f) 
     (close f) 
     (princ "\n线、图块、文字的数量信息已写入到 D:\\output\\information.txt") 
     (princ) 
    ) 
   
  (vl-load-com) 
  (setq AcadObject (vlax-get-acad-object) 
        AcadDocument (vla-get-ActiveDocument AcadObject) 
  ) 
   
  (setq Documents (vla-get-Documents (vla-get-Application AcadDocument))) 
   
   
  (setq f (open "d:\\output\\dwgs.txt" "r")) 
  (if (null f) 
     (alert "d:\\output\\dwgs.txt文件不存在!\n请建立!") 
     (progn 
        (while (setq filestring (read-line f)) 
         
           (setq activedoc (vla-open Documents filestring)) 
           (if (/= activedoc nil) 
              (progn 
              (layerprint activedoc) 
               (information activedoc) 
               (blockprint activedoc) 
               (textstyleprint activedoc) 
                 (vla-close activedoc) 
              ) 
           ) 
              
           
           
        ) 
        (close f) 
     ) 
  ) 
  (princ) 
)

lt_zzy · 发表于 2005-12-6 14:14:16

楼上改过的程序有两个问题，
1、不能将文件路径中的“\\”改成“\”；
2、不能将新打开的文件设成当前文件，否则程序将会中断，得点击那个运行程序的文件才能继续。

snoopychen · 发表于 2005-12-6 17:06:52

第一个问题比较奇怪，我在Lisplink中是\\的，来了这边变成单个\，可能是格式问题，容我改过
查了一下，我原来用的是php代码，有这个bug，现在改成code代码，就可以了

第二个问题我并没有改到，原程序似乎也有如此问题（不知道在楼主那里是否没有，
如若没有，倒是有点想不通）
仔细查了一下，是 (vla-activate doc)的问题，把它去掉应该就可以了
二楼的程序重新修改过了，楼主看看是不是已经可以：）

lt_zzy · 发表于 2005-12-6 17:30:02

我前面说得那两个问题我都已经改过了。
现在的问题就是文字样式，不完全正确，有的时候这个图形的文字样式会出现上一个图形文件的文字样式，（很少出现，但是我碰到了）。

老是打开图形，执行的速度比较慢，有没有不打开的图形就能获得上面说到的信息的方法？？

snoopychen · 发表于 2005-12-6 17:45:43

：）不想打开图形的话，我认为可以用什么软件批量转化为DXF
直接用LISP对DXF文本进行查询就可以
要是懂的DWG的格式，应该也可以这样作吧

eachy · 发表于 2005-12-6 18:33:14

不打开图形的方法要使用ObjectDBX，LUCAS发过很多很好的例子

lt_zzy · 发表于 2005-12-6 22:20:35

EACHY，估计我一时半会也学不会，还是麻烦你给我做一个吧。先谢谢你了。

eachy · 发表于 2005-12-7 02:58:06

写了一部分，用ObjectDBX就没有 SSGET 了，只能 Vlax-for Modelspace。剩下的工作你自己先修改了。

声明：本程序只是一个思路，并不能运行，包括错误。

(defun ms_getfilem (maxfs flags diatl filter initdir / wincomdlg)
(vl-load-com)
(if (not (vlax-create-object "mscomdlg.commondialog"))
(vl-registry-write
"HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905"
""
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
)
)
(setq wincomdlg (vlax-create-object "mscomdlg.commondialog"))
(vlax-put-property wincomdlg 'cancelerror :vlax-false)
(vlax-put-property wincomdlg 'maxfilesize maxfs)
(vlax-put-property
wincomdlg
'flags
flags
)
(vlax-put-property wincomdlg 'dialogtitle diatl)
(vlax-put-property
wincomdlg
'filter
filter
)
(vlax-put-property wincomdlg 'initdir initdir)
(vlax-invoke-method wincomdlg 'showopen)
(setq filem (vlax-get wincomdlg 'filename))
(vlax-release-object wincomdlg)
(fstr->lst filem)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun fstr->lst (fm / n)
(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)))
)
)
)
(defun c:tt (/ app dbxdoc diatl dwgs filename filter flags initdir maxfs
path)
(defun layerprint (doc / layersel layerobj layername f)
(setq layersel (vla-get-layers doc))
(setq filename (vla-get-name doc))
(setq f (open "d:\\output\\layers.txt" "a"))
(write-line filename f)
(vlax-for layerObj layersel
(setq layername (vla-get-name layerObj))
(write-line layername f)
)
(close f)
(princ "\n图层的列表信息已写入到 D:\\output\\layers.txt")
(princ)
)
(defun textstyleprint
(doc / textstylesel textstyleobj textstylename f)
(setq filename (vla-get-name doc))
(setq textstylesel (vla-get-textstyles doc))
(setq f (open "d:\\output\\textstyles.txt" "a"))
(write-line filename f)
(vlax-for textstyleObj textstylesel
(setq textstylename (vla-get-name textstyleObj))
(write-line textstylename f)
)
(close f)
(princ
"\n文字样式的列表信息已写入到 D:\\output\\textstyles.txt"
)
(princ)
)
(defun blockprint (doc / blocksel blockobj blockname i f)
(setq filename (vla-get-name doc))
(setq blocksel (vla-get-blocks doc)
i 0
)
(vlax-for blockObj blocksel
(setq blockname (vla-get-name blockObj))
(if (/= (substr blockname 1 1) "*")
(progn
(setq i (1+ i))
)
)
)
(if (/= i 0)
(progn
(setq f (open "d:\\output\\blocks.txt" "a"))
(write-line filename f)
(vlax-for blockObj blocksel
(setq blockname (vla-get-name blockObj))
(if (/= (substr blockname 1 1) "*")
(write-line blockname f)
)
)
(close f)
(princ "\n文字样式的列表信息已写入到 D:\\output\\blocks.txt"
)
)
(princ "\n******图中不存在有名图块! ******")
)
(princ)
)
(defun information (doc / filename linenumber
blocknumber textnumber linesel blocksel
textsel f
)
(setq filename (vla-get-name doc))
(vla-activate doc)
(setq linesel (ssget "X" '((0 . "*LINE"))))
(setq blocksel (ssget "X" '((0 . "INSERT"))))
(setq textsel (ssget "X" '((0 . "*TEXT"))))
(if (/= linesel nil)
(setq linenumber (sslength linesel))
(setq linenumber 0)
)
(if (/= blocksel nil)
(setq blocknumber (sslength blocksel))
(setq blocknumber 0)
)
(if (/= textsel nil)
(setq textnumber (sslength textsel))
(setq textnumber 0)
)
(setq f (open "d:\\output\\information.txt" "a"))
(write-line
(strcat filename
" "
(itoa linenumber)
" "
(itoa blocknumber)
" "
(itoa textnumber)
)
f
)
(close f)
(princ
"\n线、图块、文字的数量信息已写入到 D:\\output\\information.txt"
)
(princ)
)
(setq maxfs 32767
flags (+ 4 512 524288 1048576 1024)
diatl "请选择"
filter "处理(*.dwg)|*.dwg"
initdir ""
)
(if path
(setq initdir path)
(setq initdir "")
)
(setq dwgs (ms_getfilem maxfs flags diatl filter initdir))
(if (/= (car dwgs) "")
(progn
(setq app (vlax-get-acad-object))
(setq path (car dwgs)
dwgs (cdr dwgs)
)
(foreach fn dwgs
(setq dbxdoc (vla-getinterfaceobject
app
"objectdbx.axdbdocument.16"
)
)
(vla-open dbxdoc (strcat path fn))
(layerprint dbxdoc)
(information dbxdoc)
(blockprint dbxdoc)
(textstyleprint dbxdoc)
(vlax-release-object dbxdoc)
)
)
)
(princ)
)

(defun ms_getfilem (maxfs flags diatl filter initdir / wincomdlg) 
  (vl-load-com) 
  (if (not (vlax-create-object "mscomdlg.commondialog")) 
    (vl-registry-write 
      "HKEY_CLASSES_ROOT\\LICENSES\\4d553650-6abe-11cf-8adb-00aa00c00905" 
      "" 
      "gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj" 
    ) 
  ) 
  (setq wincomdlg (vlax-create-object "mscomdlg.commondialog")) 
  (vlax-put-property wincomdlg 'cancelerror :vlax-false) 
  (vlax-put-property wincomdlg 'maxfilesize maxfs) 
  (vlax-put-property 
    wincomdlg 
    'flags 
    flags 
  ) 
  (vlax-put-property wincomdlg 'dialogtitle diatl) 
  (vlax-put-property 
    wincomdlg 
    'filter 
    filter 
  ) 
  (vlax-put-property wincomdlg 'initdir initdir) 
  (vlax-invoke-method wincomdlg 'showopen) 
  (setq filem (vlax-get wincomdlg 'filename)) 
  (vlax-release-object wincomdlg) 
  (fstr->lst filem) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun fstr->lst (fm / n) 
  (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))) 
    ) 
  ) 
) 
(defun c:tt (/ app dbxdoc diatl        dwgs filename filter flags initdir maxfs 
             path) 
  (defun layerprint (doc / layersel layerobj layername f) 
    (setq layersel (vla-get-layers doc)) 
    (setq filename (vla-get-name doc)) 
    (setq f (open "d:\\output\\layers.txt" "a")) 
    (write-line filename f) 
    (vlax-for layerObj layersel 
      (setq layername (vla-get-name layerObj)) 
      (write-line layername f) 
    ) 
    (close f) 
    (princ "\n图层的列表信息已写入到 D:\\output\\layers.txt") 
    (princ) 
  ) 
 
  (defun textstyleprint 
         (doc / textstylesel textstyleobj textstylename f) 
    (setq filename (vla-get-name doc)) 
    (setq textstylesel (vla-get-textstyles doc)) 
    (setq f (open "d:\\output\\textstyles.txt" "a")) 
    (write-line filename f) 
    (vlax-for textstyleObj textstylesel 
      (setq textstylename (vla-get-name textstyleObj)) 
      (write-line textstylename f) 
    ) 
    (close f) 
    (princ 
      "\n文字样式的列表信息已写入到 D:\\output\\textstyles.txt" 
    ) 
    (princ) 
  ) 
 
  (defun blockprint (doc / blocksel blockobj blockname i f) 
    (setq filename (vla-get-name doc)) 
    (setq blocksel (vla-get-blocks doc) 
          i           0 
    ) 
    (vlax-for blockObj blocksel 
      (setq blockname (vla-get-name blockObj)) 
      (if (/= (substr blockname 1 1) "*") 
        (progn 
          (setq i (1+ i)) 
        ) 
      ) 
    ) 
    (if        (/= i 0) 
      (progn 
        (setq f (open "d:\\output\\blocks.txt" "a")) 
        (write-line filename f) 
        (vlax-for blockObj blocksel 
          (setq blockname (vla-get-name blockObj)) 
          (if (/= (substr blockname 1 1) "*") 
            (write-line blockname f) 
          ) 
        ) 
        (close f) 
        (princ "\n文字样式的列表信息已写入到 D:\\output\\blocks.txt" 
        ) 
      ) 
      (princ "\n******图中不存在有名图块! ******") 
    ) 
    (princ) 
  ) 
 
  (defun information (doc          /              filename          linenumber 
                      blocknumber textnumber  linesel          blocksel 
                      textsel          f 
                     ) 
    (setq filename (vla-get-name doc)) 
    (vla-activate doc) 
    (setq linesel (ssget "X" '((0 . "*LINE")))) 
    (setq blocksel (ssget "X" '((0 . "INSERT")))) 
    (setq textsel (ssget "X" '((0 . "*TEXT")))) 
    (if        (/= linesel nil) 
      (setq linenumber (sslength linesel)) 
      (setq linenumber 0) 
    ) 
    (if        (/= blocksel nil) 
      (setq blocknumber (sslength blocksel)) 
      (setq blocknumber 0) 
    ) 
    (if        (/= textsel nil) 
      (setq textnumber (sslength textsel)) 
      (setq textnumber 0) 
    ) 
    (setq f (open "d:\\output\\information.txt" "a")) 
    (write-line 
      (strcat filename 
              "         " 
              (itoa linenumber) 
              "         " 
              (itoa blocknumber) 
              "         " 
              (itoa textnumber) 
      ) 
      f 
    ) 
    (close f) 
    (princ 
      "\n线、图块、文字的数量信息已写入到 D:\\output\\information.txt" 
    ) 
    (princ) 
  ) 
  (setq        maxfs        32767 
        flags        (+ 4 512 524288 1048576 1024) 
        diatl        "请选择" 
        filter        "处理(*.dwg)|*.dwg" 
        initdir        "" 
  ) 
  (if path 
    (setq initdir path) 
    (setq initdir "") 
  ) 
  (setq dwgs (ms_getfilem maxfs flags diatl filter initdir)) 
  (if (/= (car dwgs) "") 
    (progn 
      (setq app (vlax-get-acad-object)) 
      (setq path (car dwgs) 
            dwgs (cdr dwgs) 
      ) 
      (foreach fn dwgs 
        (setq dbxdoc (vla-getinterfaceobject 
                       app 
                       "objectdbx.axdbdocument.16" 
                     ) 
        ) 
        (vla-open dbxdoc (strcat path fn)) 
        (layerprint dbxdoc) 
        (information dbxdoc) 
        (blockprint dbxdoc) 
        (textstyleprint dbxdoc) 
        (vlax-release-object dbxdoc) 
      ) 
    ) 
  ) 
  (princ) 
)

eachy · 发表于 2005-12-8 18:47:53

下午抽时间写完了，要是会VB的话是不是可以写个EXE文件，不用启动CAD就能写出需要的信息：）

;|
第一次使用 ObjectDBX，其实在Lisp中，ObjectDBX使用的
方法和在Activedocument中类似的。
XP+CAD2006 基本可用
尚需完善部分
1 状态行进度提示可以更直观些
2 对 dwgs 的处理可以更好些
written by eachy [[url]www.xdcad.net[/url]] 2005.12.8
|;
(defun xdl-getfiles (msg ext / x erg)
(if (or (setq x (vlax-create-object "UserAccounts.CommonDialog"))
(setq x (vlax-create-object "MSComDlg.CommonDialog"))
)
(progn (vlax-put-property x "Filename" ext)
(vlax-put-property x "Filter" ext)
(vlax-put-property x "Flags" 512)
(setq r (vlax-invoke-method x 'ShowOpen))
(if (= 0 r)
nil
(vlax-get-property x 'FileName)
)
)
nil
)
)
(defun c:tt (/ myerr olderr dwgs app path prossfn)
(defun prossfn (fn / layers blocks textstyles
blks blockname bn tn ln
textstylename ename ent layername
f openfl
)
(defun openfl (fl / file)
(if (not (setq file (open fl "a")))
(open fl "w")
file
)
)
(grtext -2
(strcat "正在处理 "
fn
)
)
(vla-open dbxdoc fn)
;;get layers info
(setq layers (vla-get-layers dbxdoc)
textstyles (vla-get-textstyles dbxdoc)
blocks (vla-get-blocks dbxdoc)
)
(setq f (openfl "d:\\output\\layers.txt"))
(write-line fn f)
(vlax-for layerObj layers
(setq layername (vla-get-name layerObj))
(write-line layername f)
)
(close f)
;;get textstyles info
(setq f (openfl "d:\\output\\textstyles.txt"))
(write-line fn f)
(vlax-for textstyleObj textstyles
(setq textstylename (vla-get-name textstyleObj))
(write-line textstylename f)
)
(close f)
;;get blocks info
(vlax-for blockobj blocks
(setq blockname (vla-get-name blockObj))
(if (/= (substr blockname 1 1) "*")
(setq blks (cons blockname blks))
)
)
(if blks
(progn
(setq f (openfl "d:\\output\\blocks.txt"))
(write-line fn f)
(foreach ff blks
(write-line ff f)
)
(close f)
)
)
;;get entity info
(vlax-for ent (vla-get-modelspace dbxdoc)
(setq ename (strcase (vla-get-objectname ent)))
(cond
((wcmatch ename "*LINE")
(if (not ln)
(setq ln 1)
(setq ln (1+ ln))
)
)
((wcmatch ename "INSERT")
(if (not bn)
(setq bn 1)
(setq bn (1+ bn))
)
)
((wcmatch ename "*TEXT")
(if (not tn)
(setq tn 1)
(setq tn (1+ tn))
)
)
(t)
)
)
(setq f (openfl "d:\\output\\information.txt"))
(write-line
(strcat fn
" "
(if (not ln)
"0"
(itoa ln)
)
" "
(if (not bn)
"0"
(itoa bn)
)
" "
(if (not tn)
"0"
(itoa tn)
)
)
f
)
(close f)
)
(defun myerr (msg)
(if (/= msg "Cancel")
(princ "\n*Cancel*")
)
(vlax-release-object dbxdoc)
(setq *error* olderr)
(princ)
)
;;main program
(if (and (setq dwgs (xdl-getfiles "选择需处理图形" "*.dwg"))
(/= dwgs "*.dwg") ;_ canceled
)
(progn
(setq olderr *error*
*error* myerr
)
(setq app (vlax-get-acad-object)
dbxdoc (vla-getinterfaceobject
app
"objectdbx.axdbdocument.16"
) ;_Only For 2004+
)
(if (vl-string-search " " dwgs)
(progn
(setq dwgs (mapcar 'vl-princ-to-string
(read (strcat "(" dwgs ")"))
)
path (car dwgs)
dwgs (mapcar '(lambda (x) (strcat path x ".dwg"))
(cdr dwgs)
)
)
(foreach fn dwgs
(prossfn fn)
)
)
(prossfn dwgs)
)
(vlax-release-object dbxdoc)
(setq *error* olderr)
)
)
(princ)
)

;| 
 
第一次使用 ObjectDBX，其实在Lisp中，ObjectDBX使用的 
方法和在Activedocument中类似的。 
 
XP+CAD2006 基本可用 
 
尚需完善部分 
 
1 状态行进度提示可以更直观些 
2 对 dwgs 的处理可以更好些 
 
written by eachy [[url]www.xdcad.net[/url]] 2005.12.8 
|; 
(defun xdl-getfiles (msg ext / x erg) 
  (if (or (setq x (vlax-create-object "UserAccounts.CommonDialog")) 
          (setq x (vlax-create-object "MSComDlg.CommonDialog")) 
      ) 
    (progn (vlax-put-property x "Filename" ext) 
           (vlax-put-property x "Filter" ext) 
           (vlax-put-property x "Flags" 512) 
           (setq r (vlax-invoke-method x 'ShowOpen)) 
           (if (= 0 r) 
             nil 
             (vlax-get-property x 'FileName) 
           ) 
    ) 
    nil 
  ) 
) 
(defun c:tt (/ myerr olderr dwgs app path prossfn) 
  (defun prossfn (fn            /              layers        blocks          textstyles 
                  blks            blockname bn        tn          ln 
                  textstylename              ename        ent          layername 
                  f            openfl 
                 ) 
    (defun openfl (fl / file) 
      (if (not (setq file (open fl "a"))) 
        (open fl "w") 
        file 
      ) 
    ) 
    (grtext -2 
            (strcat "正在处理  " 
                    fn 
            ) 
    ) 
    (vla-open dbxdoc fn) 
    ;;get layers info 
    (setq layers     (vla-get-layers dbxdoc) 
          textstyles (vla-get-textstyles dbxdoc) 
          blocks     (vla-get-blocks dbxdoc) 
    ) 
    (setq f (openfl "d:\\output\\layers.txt")) 
    (write-line fn f) 
    (vlax-for layerObj layers 
      (setq layername (vla-get-name layerObj)) 
      (write-line layername f) 
    ) 
    (close f) 
    ;;get textstyles info 
    (setq f (openfl "d:\\output\\textstyles.txt")) 
    (write-line fn f) 
    (vlax-for textstyleObj textstyles 
      (setq textstylename (vla-get-name textstyleObj)) 
      (write-line textstylename f) 
    ) 
    (close f) 
    ;;get blocks info 
    (vlax-for blockobj blocks 
      (setq blockname (vla-get-name blockObj)) 
      (if (/= (substr blockname 1 1) "*") 
        (setq blks (cons blockname blks)) 
      ) 
    ) 
    (if        blks 
      (progn 
        (setq f (openfl "d:\\output\\blocks.txt")) 
        (write-line fn f) 
        (foreach ff blks 
          (write-line ff f) 
        ) 
        (close f) 
      ) 
    ) 
    ;;get entity info 
    (vlax-for ent (vla-get-modelspace dbxdoc) 
      (setq ename (strcase (vla-get-objectname ent))) 
      (cond 
        ((wcmatch ename "*LINE") 
         (if (not ln) 
           (setq ln 1) 
           (setq ln (1+ ln)) 
         ) 
        ) 
        ((wcmatch ename "INSERT") 
         (if (not bn) 
           (setq bn 1) 
           (setq bn (1+ bn)) 
         ) 
        ) 
        ((wcmatch ename "*TEXT") 
         (if (not tn) 
           (setq tn 1) 
           (setq tn (1+ tn)) 
         ) 
        ) 
        (t) 
      ) 
    ) 
    (setq f (openfl "d:\\output\\information.txt")) 
    (write-line 
      (strcat fn 
              "         " 
              (if (not ln) 
                "0" 
                (itoa ln) 
              ) 
              "         " 
              (if (not bn) 
                "0" 
                (itoa bn) 
              ) 
              "         " 
              (if (not tn) 
                "0" 
                (itoa tn) 
              ) 
      ) 
      f 
    ) 
    (close f) 
  ) 
  (defun myerr (msg) 
    (if        (/= msg "Cancel") 
      (princ "\n*Cancel*") 
    ) 
    (vlax-release-object dbxdoc) 
    (setq *error* olderr) 
    (princ) 
  ) 
  ;;main program   
  (if (and (setq dwgs (xdl-getfiles "选择需处理图形" "*.dwg")) 
           (/= dwgs "*.dwg") ;_ canceled 
      ) 
    (progn 
      (setq olderr  *error* 
            *error* myerr 
      ) 
      (setq app           (vlax-get-acad-object) 
            dbxdoc (vla-getinterfaceobject 
                     app 
                     "objectdbx.axdbdocument.16" 
                   ) ;_Only For 2004+ 
      ) 
      (if (vl-string-search " " dwgs) 
        (progn 
          (setq        dwgs (mapcar 'vl-princ-to-string 
                             (read (strcat "(" dwgs ")")) 
                     ) 
                path (car dwgs) 
                dwgs (mapcar '(lambda (x) (strcat path x ".dwg")) 
                             (cdr dwgs) 
                     ) 
          ) 
          (foreach fn dwgs 
            (prossfn fn) 
          ) 
        ) 
        (prossfn dwgs) 
      ) 
      (vlax-release-object dbxdoc) 
      (setq *error* olderr) 
    ) 
  ) 
  (princ) 
)

lt_zzy · 发表于 2005-12-9 12:03:39

EACHY，单个双击文件的时候可以导出图形文件的信息，选择全部文件的时候不执行，也没有错误信息。

LUCAS · 发表于 2005-12-9 13:11:39

你有先建立"d:\\output" 这个目录吗?

lt_zzy · 发表于 2005-12-9 13:25:58

我建立了这个目录。执行结果却没有出来。

LUCAS · 发表于 2005-12-9 17:14:59

;;ObjectDBX 要先注册
(defun REGISTEROBJECTDBX (/ DBXSERVER)
(cond
((vl-registry-read
"HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
)
)
((not (setq DBXSERVER (findfile "AxDb15.dll")))
(alert "错误: Can't locate ObjectDBX Library (AxDb15.dll)")
)
(t
(startapp "regsvr32.exe" (strcat "/s "" DBXSERVER """))
(or
(vl-registry-read
"HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID"
)
(alert
"错误: Failed to register ObjectDBX ActiveX services."
)
)
)
)
)
(defun DBX ()
(if (> (atoi (getvar "AcadVer")) 15)
(setq DBXDOC (vla-getinterfaceobject
(vlax-get-acad-object)
"ObjectDBX.AxDbDocument.16"
)
)
(progn
(if (not (REGISTEROBJECTDBX))
(exit)
)
(setq DBXDOC (vla-getinterfaceobject
(vlax-get-acad-object)
"ObjectDBX.AxDbDocument"
)
)
)
)
(if (not DBXDOC)
(exit)
)
)

;;ObjectDBX 要先注册 
(defun REGISTEROBJECTDBX (/ DBXSERVER) 
  (cond 
    ((vl-registry-read 
       "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID" 
     ) 
    ) 
    ((not (setq DBXSERVER (findfile "AxDb15.dll"))) 
     (alert "错误: Can't locate ObjectDBX Library (AxDb15.dll)") 
    ) 
    (t 
     (startapp "regsvr32.exe" (strcat "/s "" DBXSERVER """)) 
     (or 
       (vl-registry-read 
         "HKEY_CLASSES_ROOT\\ObjectDBX.AxDbDocument\\CLSID" 
       ) 
       (alert 
         "错误: Failed to register ObjectDBX ActiveX services." 
       ) 
     ) 
    ) 
  ) 
) 
 
(defun DBX () 
     (if (> (atoi (getvar "AcadVer")) 15) 
    (setq DBXDOC (vla-getinterfaceobject 
                   (vlax-get-acad-object) 
                   "ObjectDBX.AxDbDocument.16" 
                 ) 
    ) 
    (progn 
      (if (not (REGISTEROBJECTDBX)) 
        (exit) 
      ) 
      (setq DBXDOC (vla-getinterfaceobject 
                     (vlax-get-acad-object) 
                     "ObjectDBX.AxDbDocument" 
                   ) 
      ) 
    ) 
  ) 
  (if (not DBXDOC) 
    (exit) 
  ) 
)

eachy · 发表于 2005-12-9 18:47:06

命令：GetInfo

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

[求助] [求助]：一个导出图形的线，文本，图块，图层，文字样式的程序问题

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

相关帖子