Send attributes to specific Excel sheet

I would like to know if there's a way to send my part numbers (block attributes) to Excel and have them populate to a worksheet named the same as the drawing they came from.

excel file = Myproject.xls

drawing file names = Item 1.dwg, Item 2.dwg, Item 3.dwg

excel sheet names = match the drawing file names

Each drawing contains several blocks, each block with its part number stored as an attribute.

I would like to be able to create each drawing by inserting blocks, then be able to click a button that sends all of the part numbers in Item 1.dwg to Myproject.xls and dumps onto sheet Item 1.

I would then proceed to creating Item 2 and Item 3.dwg, and be able to click the "send to Excel" button, which would send to the same Myproject.xls

Basically, what I would like to do is collect all part numbers from many drawing into one Main Project Excel file.

It's been 10 years since I've worked with any lisp programming and I don't remember most of what I did know. - Now, it seems there are all sorts of programming options to use... My question is, can this be done at all? And, if so, what method would the experts recommend using.

If it would be simplier to have all the drawings done and then open Excel and run some extraction code to pull the data in from each of the drawing at the end, that would be good too.

Any help would be greatly appreciated.

hmm..this is one of those yes it should be possible..

From my perspective in VBA yes...not sure about LISP though.

This might get you started, is it something like what you're looking for?

    'The following will cycle throught the Attributes, and put each
   'block's attribut chart on a seperate worksheet, then you just save
   'the workbook. You can put this in a sub routine, and call it when
   'you need it, so you could have another loop elsewhere in your
   'program that would cycle through your drawings and call this sub
   'for each.
   
   For i = 0 To A2K4dwg.ModelSpace.Count - 1
       'Check to see that the entity is a Block Reference
       If A2K4dwg.ModelSpace.Item(i).EntityType = acBlockReference Then
           If A2K4dwg.ModelSpace.Item(i).HasAttributes Then
               'Store the attribute references in an array, extract
               'the data, and put it into a cell
               Attr = A2K4dwg.ModelSpace.Item(i).GetAttributes
               For j = 0 To UBound(Attr)
                   YourXLDoc.Worksheets(i).Range(Cells(j + 1, 1).Address).Value = Attr(j).TagString
                   YourXLDoc.Range(Cells(j + 1, 2).Address).Value = Attr(j).TextString
               Next j
           End If
       End If
   Next i
   'Then save your Worksheet (You can find that)

See this thread on how to cycle through Documents, it's the For each Document in Documents" part.

I haven't done any lisp, but I'm pretty sure it's not possible to access Excel with it, you'll have to use VB I think. See if that can get you started.

Kirk

(vl-load-com)
(defun mip-reg-get-path ()"HKEY_LOCAL_MACHINE\\Software\\MIP")
(defun mip-reg-write (key value ) ;;;Ïèøåì â ïðîôèëü â ïêïêó ÌÈÏ
(vl-registry-write (mip-reg-get-path)
(VL-PRINC-TO-STRING key)(VL-PRINC-TO-STRING value)))
(defun mip-reg-read ( key )(vl-registry-read (mip-reg-get-path)
(VL-PRINC-TO-STRING key)))
(defun mip-conv-to-str (dat)(if dat (vl-princ-to-string dat) ""))
(defun get-all-atts (obj)
 (if (and obj
   (eq :vlax-true (vla-get-HasAttributes obj))
   (vlax-property-available-p obj 'Hasattributes))
   (vl-catch-all-apply (function (lambda()
  (mapcar (function (lambda (x)
        (cons (vla-get-TagString x)
       (vla-get-TextString x))))
   (append (vlax-invoke obj 'Getattributes)
    (vlax-invoke obj 'Getconstantattributes)
   )))))))
;|================== XLSF ========================================
* Arguments:
             punto_datos - The list of lists of data (LIST) 
                           ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                           Each list of a kind (Value1 Value2... VlalueN) enters the name in
                           a separate line in corresponding columns (Value1-A Value2-B and .ò.ä.)
                 header -  The list (LIST) headings or nil a kind (" Signature A " " Signature B "...)
                           If header nil, is accepted ("X" "Y" "Z")
                Colhide -  The list of alphabetic names of columns to hide or nil - to not hide ("A" "C" "D") - to hide columns A, C, D
                Name_list - The name of a new leaf of the active book or nil - is not present
                filename  - xls file
* Return: nil
* Usage
(xlsf '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Col1" "Col2" "Col3"  "Col4") '("B") "test" (getfiled "Excel Spreadsheet File" "" "XLS" )   |;
(defun xlsf ( punto_datos header Colhide Name_list filename / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26) 
 TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
 Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))   
 (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
  (vlax-invoke-method (vlax-get-property  *AplExcel*  'WorkBooks) 'Open fileName)
   (vla-put-visible  *AplExcel*  1)
(setq *Books-Colection* (vlax-get *AplExcel* "Workbooks"))
(setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
(setq *Sheet-Collection* (vlax-get-property *New-Book* "Sheets"))  
(setq *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))  
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                 (vl-filename-base(getvar "DWGNAME"))
                 (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
  col 0 cols nil)
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)  
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)    
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))  
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false)
(vlax-put-property *AplExcel* "DecimalSeparator" ".")
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
  (strcat "A1:" (letter col)(itoa row)))))
(setq cols (vlax-get-property cell  'Columns))  
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))  
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
  (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))    
(vlax-put-property cols 'hidden 1)  
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)  
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(defun C:SETXLSFILE ( / fn1)
(setq fn1 (getfiled "Excel Spreadsheet File" (if oldFileName oldFileName "") "XLS" )
(mip-reg-write "LASTXLSDIR" (vl-filename-directory fn1))
(mip-reg-write "LASTXLSFILE" (strcat (vl-filename-base fn1)(vl-filename-extension fn1)))
 (princ))
(defun C:ATTEXP2XL ( / fn1 filename blk pat head ss datalist att_list)
(setq fn1 (strcat (mip-conv-to-str(mip-reg-read "LASTXLSDIR")) "\\"
   (mip-conv-to-str(mip-reg-read "LASTXLSFILE"))))
(if (vl-file-systime fn1)
 (setq fileName fn1)
 (setq fileName (getfiled "Excel Spreadsheet File" (if oldFileName oldFileName "") "XLS" )
 )
(if (vl-file-systime (vl-princ-to-string fileName))
 (progn
   (setq oldFileName fileName)
   (princ "\nChoose a block")
   (while (not(setq ss (ssget "_+.:S:E" '((0 . "INSERT")(66 . 1)))))
     (princ "\nWrong... Choose a block with attributes"))
   (setq blk (ssname ss 0) ss nil)
   (setq pat (vl-remove-if-not '(lambda(x)(member (car x) '(0 2 410)))(entget blk)))
   (setq head nil datalist nil)
   (if (setq ss (ssget "_X" pat))
     (progn
     (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
       (setq att_list (get-all-atts item))
       (if (null head)(setq head (mapcar 'car att_list)))
       (setq datalist (append datalist (list (mapcar 'cdr att_list))))
     )
     (xlsf datalist head nil nil fileName)
     )
     )
   )
 (alert (strcat "Cann't open\n" filename "\nMay be open or missing"))
 )
 (princ)
 )

Two commands

SETXLSFILE - remembers a name of a file

ATTEXP2XL - exports attributes of the block to a file

Perfect routine VVA

Thanks

EXCELLENT!!! VVA

Hi guys how do you make to work this code in autocad?

thanks for your input...

Hi guys how do you make to work this code in autocad?

 

thanks for your input...

http://www.cadtutor.net/forum/showthread.php?t=1390

Sorry for my for bad English.

I would act on another. Following commands send the information in active document Excell, if it is not present it is created.

It is enough to open the necessary file before a call of a command and to send it the necessary information.

Next two commnads:

ATTEXP2XL - exports attributes of the block to active document Excell to specific sheet

AREAS - Send the Layer, area, length, color, a hyperlink of selected polyline in corresponding columns Excel.

(vl-load-com)
(defun mip-conv-to-str (dat)(if dat (vl-princ-to-string dat) ""))
(defun get-all-atts (obj)
 (if (and obj
   (eq :vlax-true (vla-get-HasAttributes obj))
   (vlax-property-available-p obj 'Hasattributes))
   (vl-catch-all-apply (function (lambda()
  (mapcar (function (lambda (x)
        (cons (vla-get-TagString x)
       (vla-get-TextString x))))
   (append (vlax-invoke obj 'Getattributes)
    (vlax-invoke obj 'Getconstantattributes)
   )))))))
;|================== XLS ========================================
* Purpose: Export of the list of data punto_datos in Excell
*             It is exported to a new leaf of the current book.
             If the book is not present, it is created
* Arguments:
             punto_datos - The list of lists of data (LIST) 
                           ((Value1 Value2 ... VlalueN)(Value1 Value2 ... VlalueN)...)
                           Each list of a kind (Value1 Value2... VlalueN) enters the name in
                           a separate line in corresponding columns (Value1-A Value2-B and .ò.ä.)
                 header -  The list (LIST) headings or nil a kind (" Signature A " " Signature B "...)
                           If header nil, is accepted ("X" "Y" "Z")
                Colhide -  The list of alphabetic names of columns to hide or nil - to not hide ("A" "C" "D") - to hide columns A, C, D
                Name_list - The name of a new leaf of the active book or nil - is not present
* Return: nil
* Usage
(xls '((1.1 1.2 1.3 1.4)(2.1 2.2 2.3 2.4)(3.1 3.2 3.3 3.4)) '("Col1" "Col2" "Col3"  "Col4") '("B") "test")   |;
(vl-load-com)
(defun xls ( punto_datos header Colhide Name_list / *aplexcel* *books-colection* Currsep
*excell-cells* *new-book* *sheet#1* *sheet-collection* col iz_listo row cell cols)
(defun Letter (N / Res TMP)(setq Res "")(while (> N 0)(setq TMP (rem N 26) 
 TMP (if (zerop TMP)(setq N (1- N) TMP 26) TMP)
 Res (strcat (chr (+ 64 TMP)) Res)  N   (/ N 26))) Res)
(if (null Name_list)(setq Name_list ""))   
 (setq  *AplExcel*     (vlax-get-or-create-object "Excel.Application"))
 (if (setq *New-Book*  (vlax-get-property *AplExcel* "ActiveWorkbook"))
   (setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
         *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
              *Sheet#1*     (vlax-invoke-method *Sheet-Collection* "Add"))
(setq *Books-Colection*  (vlax-get-property *AplExcel* "Workbooks")
             *New-Book*     (vlax-invoke-method *Books-Colection* "Add")
         *Sheet-Collection* (vlax-get-property *New-Book* "Sheets")
              *Sheet#1*     (vlax-get-property *Sheet-Collection* "Item" 1)))
(setq *excell-cells*     (vlax-get-property *Sheet#1* "Cells"))
(setq Name_list (if (= Name_list "")
                 (vl-filename-base(getvar "DWGNAME"))
                 (strcat (vl-filename-base(getvar "DWGNAME")) "&" Name_list))
  col 0 cols nil)
(vlax-for sh *Sheet-Collection* (setq cols (cons (strcase(vlax-get-property sh 'Name)) cols)))
(setq row Name_list)  
(while (member (strcase row) cols)(setq row (strcat Name_list " (" (itoa(setq col (1+ col)))")")))
(setq Name_list row)    
(vlax-put-property *Sheet#1* 'Name Name_list)
(setq Currsep (vlax-get-property *AplExcel* "UseSystemSeparators"))  
(vlax-put-property *AplExcel* "UseSystemSeparators" :vlax-false) ;_êå èñïîëüçîâêòü ñèñòåìêûå óñòêêîâêè
(vlax-put-property *AplExcel* "DecimalSeparator" ".")            ;_ðêçäåëèòåëü äðîáêîé è öåëîé ÷êñòè
(vlax-put-property *AplExcel* "ThousandsSeparator" " ")          ;_ðêçäåëèòåëü òûñÿ÷åé
(vla-put-visible *AplExcel* :vlax-true)(setq row 1 col 1)
(if (null header)(setq header '("X" "Y" "Z")))
(repeat (length header)(vlax-put-property *excell-cells* "Item" row col
(vl-princ-to-string (nth (1- col) header)))(setq col (1+ col)))(setq  row 2 col 1)
(repeat (length punto_datos)(setq iz_listo (car punto_datos))(repeat (length iz_listo)
(vlax-put-property *excell-cells* "Item" row col (vl-princ-to-string (car iz_listo)))
(setq iz_listo (cdr iz_listo) col (1+ col)))(setq punto_datos (cdr punto_datos))(setq col 1 row (1+ row)))
(setq col (1+(length header)) row (1+ row))
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
  (strcat "A1:" (letter col)(itoa row))))) ;_ end of setq
(setq cols (vlax-get-property cell  'Columns))  
(vlax-invoke-method cols 'Autofit)
(vlax-release-object cols)(vlax-release-object cell)
(foreach item ColHide (if (numberp item)(setq item (letter item)))  
(setq cell (vlax-variant-value (vlax-invoke-method *Sheet#1* "Evaluate"
  (strcat item "1:" item "1"))))
(setq cols (vlax-get-property cell  'Columns))    
(vlax-put-property cols 'hidden 1)  
(vlax-release-object cols)(vlax-release-object cell))
(vlax-put-property *AplExcel* "UseSystemSeparators" Currsep)  
(mapcar 'vlax-release-object (list *excell-cells* *Sheet#1* *Sheet-Collection* *New-Book* *Books-Colection*
*AplExcel*))(setq *AplExcel* nil)(gc)(gc)(princ))
(defun C:ATTEXP2XL ( / blk pat head ss datalist att_list)
   (princ "\nChoose a block")
   (while (not(setq ss (ssget "_+.:S:E" '((0 . "INSERT")(66 . 1)))))
     (princ "\nWrong... Choose a block with attributes"))
   (setq blk (ssname ss 0) ss nil)
   (setq pat (vl-remove-if-not '(lambda(x)(member (car x) '(0 2 410)))(entget blk)))
   (setq head nil datalist nil)
   (if (setq ss (ssget "_X" pat))
     (progn
     (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
       (setq att_list (get-all-atts item))
       (if (null head)(setq head (mapcar 'car att_list)))
       (setq datalist (append datalist (list (mapcar 'cdr att_list))))
     )
     (xls datalist head nil nil)
     )
     )
 (princ)
 )
;|=============== Comand AREAS ================================================
Send the Layer, the area, length, color, a hyperlink in corresponding columns Excel.
See also _HYPERLINKOPTIONS |;
(defun c:AREAS (/ selset  *error* retLst lst i UrlDes are)
(defun *error* (msg)(princ msg)(princ)) ;_ end of defun
(vl-load-com)  
(if (setq selset (ssget '((0 . "*POLYLINE"))))(progn (setq i 1)
 (foreach item (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex selset))))
(if(not (zerop(vla-get-Count (vla-get-Hyperlinks item))))
 (VL-CATCH-ALL-APPLY '(lambda()(setq UrlDes(vla-get-URLDescription(vla-item (vla-get-Hyperlinks item) 0)))))
 (setq UrlDes ""))
   (setq lst (list
     (strcat "'" (vla-get-layer item))                 ;|Layer"|;
     (rtos(setq are(vla-get-area item)) 2 12)          ;|Area|;
     (rtos(vla-get-Length item) 2 12)                  ;|Length|;
     (vla-get-color item)                              ;|Color|;
     (if (= UrlDes "") "" (strcat "'" UrlDes))         ;|Hyperlink|;
     ))
 (setq retLst (append retLst (list lst))));_foreach
(xls retlst '("Layer" "Area" "Length" "Color" "Hyperlink") nil "from AREAS")))
(princ))

thanks VVA I though for vba was a different procedure.

Anyways your CODE works just fine...thank you very much!!

My life would be much easier now. I had to deal with a of attributes extraction.

one more question if you modified the extraction in excel it would make that change to the drawing?

thanks for your help!!

Good sites on work with Excell

http://www.atablex.com/

http://www.jefferypsanders.com/autolisp.html

Another code from new member:P;

You just pick a block object with attr. from Acad; this code runs Excel App. and make an attributes list of all related blocks, including header info.

Even if the block is on Model or Layout Tab

Public Sub PickBlockToExtactAttrToExcel()
Dim getAcObj        As AcadObject
Dim basePnt         As Variant
   On Error Resume Next
RETRY:
   ThisDrawing.Utility.GetEntity getAcObj, basePnt, "Pick a block to extact attributes to Excel.."
   
   If Err <> 0 Then
       Err.Clear
       Exit Sub
   Else
       If getAcObj.ObjectName <> "AcDbBlockReference" Then GoTo RETRY
   End If

Dim Array1          As Variant
Dim RowNum          As Long
   RowNum = 1
Dim elem            As AcadEntity
Dim aCount          As Long
Dim Header          As Boolean

   For Each elem In ThisDrawing.ActiveLayout.Block
       If elem.EntityName = "AcDbBlockReference" Then
           If elem.Name = getAcObj.Name Then
               If elem.HasAttributes Then
                   Array1 = elem.GetAttributes
                   If Header = False Then
                       Dim anExcelApp As Object
                       Set anExcelApp = GetObject(, "Excel.Application")
                       If Err.Number Then
                           Err.Clear
                           Set anExcelApp = CreateObject("Excel.Application")
                           If Err <> 0 Then
                               Err.Clear
                               MsgBox "Excel is not installed"
                               End
                           End If
                       End If
                       anExcelApp.Visible = True
                       anExcelApp.WindowState = 3
                       Dim anExcelActiveWorkBook As Object
                       Set anExcelActiveWorkBook = anExcelApp.Workbooks.Add
                       anExcelActiveWorkBook.Activate
                       
                       Dim anExcelActiveSheet As Object
                       Set anExcelActiveSheet = anExcelActiveWorkBook.ActiveSheet
                   
                       For aCount = LBound(Array1) To UBound(Array1)
                           If Array1(aCount).EntityName = "AcDbAttribute" Then
                               anExcelActiveSheet.Cells(RowNum, aCount + 1) = Array1(aCount).TagString
                           End If
                       Next aCount
                       RowNum = 2
                       Header = True
                   End If
   
                   For aCount = LBound(Array1) To UBound(Array1)
                       anExcelActiveSheet.Cells(RowNum, aCount + 1) = Array1(aCount).TextString
                       anExcelActiveSheet.Columns(aCount + 1).EntireColumn.AutoFit
                   Next aCount
                   RowNum = RowNum + 1
               End If
           End If
       
       End If
   Next elem
'''''
End Sub

One of the members asked for; if he can export a special number format like "001" in an attribute text, will be the same in Excel sheet;

Replace these lines of the code

                   For aCount = LBound(Array1) To UBound(Array1)
                       anExcelActiveSheet.Cells(RowNum, aCount + 1) = Array1(aCount).TextString
                       anExcelActiveSheet.Columns(aCount + 1).EntireColumn.AutoFit
                   Next aCount

as in following. Included code line will format the cells as text.

                   For aCount = LBound(Array1) To UBound(Array1)
                       anExcelActiveSheet.Cells(RowNum, aCount + 1).NumberFormat = "@"
                       anExcelActiveSheet.Cells(RowNum, aCount + 1) = Array1(aCount).TextString
                       anExcelActiveSheet.Columns(aCount + 1).EntireColumn.AutoFit
                   Next aCount

Long Live ActiveX!

hy help my i want to export all attrib from dwg you have to change everything now export to export a single attr but I want to select all and export them can you help me with this please

Hi

Have a look at LeeMac's excellent collection of LISP routines. This particular one may be of interest...

http://www.lee-mac.com/macatt.html