提取某些属性乐筑天下 - Powered by Discuz! Archiver

chauncy274 发表于 2022-7-6 15:56:54

提取某些属性

嘿伙计们，

在我工作的地方，我们传输DWG。与我们的客户一起完成每项工作，因此当我们获得DWG时。在中，我们必须手动登录每个人，并记录各种信息。

我想知道是否有可能创建一个应用程序，visual lisp或vba，可以进入DWG组。，从块“TITLE”中获取文件名和三个属性（DWGNO、Disc1和REVISION），然后将它们放入excel工作表中。实际上，我只需要代码来进入一组DWG。（从未编写过可以同时处理多个DWG的代码）以及提取该数据所需的代码。我想如果我知道怎么做，我可以很好地把它拼凑起来。

提前感谢您的帮助！

borgunit 发表于 2022-7-6 16:04:31

简而言之，答案是肯定的。你从哪里开始？你有什么东西吗？脚本是否足够？

chauncy274 发表于 2022-7-6 16:07:13

请原谅我的无知，我远没有这个论坛上的大多数人好。

脚本在这里有什么用处？我的理解是，不能用脚本读取信息，也不能在多个DWG中运行脚本。除非你打开每一个并手动运行？

现在我有一个粗略的草图，我认为程序应该如何在VBA中运行（在VBA中几乎没有经验），到目前为止几乎没有实际代码。

我想我将从一个包含我的计算机目录的对话框开始，这样我可以选择我需要的dwg文件（这可能吗），然后它应该按顺序打开它们，从标题栏中获取文件名和属性信息，所有这些都在模型空间中，并将它们打印到excel表的第1行，然后循环浏览dwg。在excel工作表上为每个dwg向下搜索一行。

BIGAL 发表于 2022-7-6 16:16:48

可以使用脚本打开任意多个图形，然后在该脚本中执行多个功能。我可以向你们保证，我在一次会议中打开了大约120个DWG，你们会惊讶于它的速度有多快。

如
checkexcelrunning（检查excel是否正在运行）
打开dwg1 myprog1 close N
打开dwg2 myprog1关闭N
打开dwg3 myprog1 close N
打开dwg4 myprog1 close N

（check for excel is running）是一个这样做的程序，这里有许多使用VBA检查excel是否打开的示例。

Myprog1是一个将属性写入excel工作表的小程序。

这里有很多示例可以让您编写myprog1。因为您知道哪个块包含dwgno disc1修订版，所以这很容易。在查看数据库时，模型空间图纸空间保存图形的位置无关紧要，它会找到块。值得注意的是，我们在大多数DWG中都有多个布局，版次不能在布局之间更改。但你可以导出每张纸的细节，这可能是最好的。

BIGAL 发表于 2022-7-6 16:20:23

除此之外，这里是更新名为“titleblock”的块的代码，我已经注意到了将属性导出到excel的点。这是一个开始。

Public Sub issued_for_construction()
' This Updates the Issued for construction and sets rev 0

Dim SS As AcadSelectionSet
Dim Count As Integer
Dim FilterDXFCode(1) As Integer
Dim FilterDXFVal(1) As Variant
Dim attribs As Variant
Dim BLOCK_NAME As String
On Error Resume Next
FilterDXFCode(0) = 0
FilterDXFVal(0) = "INSERT"
FilterDXFCode(1) = 2
FilterDXFVal(1) = "titleblock"
BLOCK_NAME = "titleblock"
Set SS = ThisDrawing.SelectionSets.Add("issued")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal

For Cntr = 0 To SS.Count - 1
attribs = SS.Item(Cntr).GetAttributes

' take these next 4 lines out and add your export to excel here !

   attribs(0).TextString = "ISSUED FOR CONSTRUCTION"
   attribs(3).TextString = "0"

   attribs(0).Update
   attribs(3).Update

Next Cntr
ThisDrawing.SelectionSets.Item("issued").Delete
'DO AGAIN FOR REVTABLE
'DATE
'Dim MyDate
'MyDate = Date
Call DashDate
FilterDXFCode(1) = 2
FilterDXFVal(1) = "REVTABLE"
BLOCK_NAME = "REVTABLE"
Set SS = ThisDrawing.SelectionSets.Add("revs")
SS.Select acSelectionSetAll, , , FilterDXFCode, FilterDXFVal

For Cntr = 0 To SS.Count - 1
attribs = SS.Item(Cntr).GetAttributes


   attribs(0).TextString = "0"
   attribs(1).TextString = DashDate
   attribs(2).TextString = "ISSUED FOR CONSTRUCTION"



   attribs(0).Update
   attribs(1).Update
   attribs(2).Update

Next Cntr
ThisDrawing.SelectionSets.Item("revs").Delete
MsgBox "Drawing now changed to Issued for Construction"
End Sub
Public Function DashDate() As String
Dim strDate As String
Dim intMonth As Integer
Dim intDay As Integer
strDate = Str(Date)
intMonth = InStr(1, strDate, "/", vbTextCompare)
intDay = InStr(intMonth, strDate, "/", vbTextCompare)
strDate = Left(strDate, intMonth - 1) & "." _
      & Mid(strDate, intMonth + 1, intDay - 1) & "." & Right(strDate, 2)
DashDate = strDate
End Function

chauncy274 发表于 2022-7-6 16:24:15

谢谢，我明天会在工作中编写这段代码，看看结果如何。可能需要更多帮助，因为我想在开始时在vba中打开一个对话框，在那里我可以选择DWG所在的目录。是的，它可以完成所有的操作，但是当我试图添加一个微软通用对话框（我被告知这是我需要的）时，它说我没有权限。我明天也得做这件事。谢谢大家！

fuccaro 发表于 2022-7-6 16:27:38

请阅读此处：http://www.cadtutor.net/forum/showthread.php?t=1950

chauncy274 发表于 2022-7-6 16:36:01

谢谢Fuccaro，看起来你的程序会帮我很多！

chauncy274 发表于 2022-7-6 16:37:57

Fuccaro，

感谢一位配载员，这段代码非常有效。我计划一有机会就把它改成我需要的excel表格上的格式。我只有一个问题，那不是你程序的错。出于某种原因，当我在我的一个公司标题栏上使用它时，它会在excel表中返回多行。有时5，有时17！当我在另一种类型的区块上使用它时（我在我自己放入dwg的其他区块上进行了尝试），它工作得很好，只打印出一行。我试图弄明白为什么它在dwg上只能找到它的一个实例时，却如此多次地拾取我们的标题栏。我附上一份标题栏的副本，它有问题。如果有人能告诉我如何解决这个问题，或者告诉我我的公司标题栏出了什么问题，我将永远感激！

块名为“DTITLE”，我试图获取属性“REVNO”和“DWGNO”。

***我将附上图纸。我在下一篇文章中谈到的你的文件和代码，因为直到我第9篇文章发表之前，它都不允许我发布它们

chauncy274 发表于 2022-7-6 16:45:23

42-07-05-020841-RSS#420-2450苯胺日计量箱（MQP）上的电导率分析仪。图纸
; Global ATTribute EXtractor
; by Miklos Fuccaro mfuccaro@hotmail.com
;-------------------------November 2004 -------
;;Edited March 2006 by C. Bassler to allow specification of block and tage names to extract
(defun gattex()
(setq Blocklist '("DTITLE"));; ** edit to include block names to select
(setq TagList '("DWGNO." "REVNO."));; ** edit to include tag names to extract
;;create block names separated by columns, for selection filter
(setq Blocknames (List2String BlockList))
(setq ss (ssget "_X" (list '(0 . "INSERT") (cons 2 BlockNames))))
(if (not ss) (quit))
(setq Root (getvar "DWGPREFIX"))
(setq file (open (strcat Root "attributes.CSV") "a") i -1)
(write-line (strcat Root (getvar "DWGNAME")
            " -found " (itoa (sslength ss))
            " block(s) with attributes") file)
(repeat (sslength ss)
   (setq TagRow nil ValRow nil)
   (setq Edata (entget (setq e (ssname ss (setq i (1+ i))))))
   (write-line "" file)
   (write-line (strcat "block name:" "," (Dxf 2 Edata)) file)
   (while (/= (Dxf 0 Edata) "SEQEND")
      (if
         (and
            (= (Dxf 0 Edata) "ATTRIB")
            (member (dxf 2 Edata) TagList);;if tag is on list
         );and
         (progn
            (setq TagRow (cons (Dxf 2 Edata) TagRow))
            (setq valRow (cons (Dxf 1 Edata) ValRow))
         );progn
      )
      (setq Edata (entget (setq e (entnext e))))
   );while
   (write-line (List2String (reverse TagRow)) file)
   (write-line (List2String (reverse ValRow)) file)
);repeat
(close file)
(princ (strcat "\nDone writing file " Root "attributes.csv"))
(princ)
);defun
;;-------------------------------
(defun List2String (Alist)
(setq NumStr (length Alist))
(foreach Item AList
   (if (= Item (car AList));;first item
      (setq LongString (car AList))
      (setq LongString (strcat LongString "," Item))
      )
)
LongString
);defun
;;--------------------------------
(defun Dxf (code pairs)
(cdr (assoc code pairs))
)
(gattex)

页: [1] 2

乐筑天下's Archiver

提取某些属性