[编程交流] 提取某些属性

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

; 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)