Batch Extraction of Attributes to Excel

[Jim Clayton]

Going to try and explain this with as little confusion as possible.  I have a series of drawings. Sometimes 1-10, sometimes 1-100.  They all have BOM's.  BOM's consist of Item#, QTY, UOM, Description, Material, & Stock Code.  I want to extract the UOM, QTY, and Stock Code from all sheets in the series and send them to an excel sheet.  The preferred execution method would be to do this from the Excel side, but I'm open to a Lisp or other suggestions.  Anyone think they might be able to help?  The BOM attributes are laid out per attachment.  Would greatly appreciate any guidance on this.  Tks.
Below link is from a thread that is similar, but in the opposite direction of what I'm trying to do...I'm not trying to extract/change/import.  I only want to extract specific attributes and put onto a spreadsheet.  Tks.
https://www.cadtutor.net/forum/topic/63793-autocad-title-block-from-excel-vba/?tab=comments#comment-525675

BOM-Model.pdf

[Jim Clayton]

Maybe something along these lines, but modified, that would allow me to select an entire range of drawings to extract data from?

Public Sub WriteAttributes()

	

	Dim oSset As AcadSelectionSet

	Dim oEnt As AcadEntity

	Dim oBlkRef As AcadBlockReference

	Dim oAtt As AcadAttributeReference

	Dim varAtt As Variant

	Dim i As Long

	Dim ftype(1) As Integer

	Dim fdata(1) As Variant

	ftype(0) = 0: fdata(0) = "INSERT"

	ftype(1) = 66: fdata(1) = 1

	Dim dxftype As Variant

	Dim dxfdata As Variant

	dxftype = ftype

	dxfdata = fdata

	'---------------------

	Dim xlApp As Object

	Dim xlBook As Workbook

	Dim xlSheet As Worksheet

	Dim lngRow As Long, lngCol As Long

	

	'---------------------

	On Error Resume Next

	Set xlApp = GetObject(, "Excel.Application")

	If Err <> 0 Then

	Err.Clear

	Set xlApp = CreateObject("Excel.Application")

	If Err <> 0 Then

	MsgBox "Impossible to initialize an Excel.", vbExclamation

	End

	End If

	End If

	'---------------------

	

	On Error Resume Next

	Set oSset = ThisDrawing.SelectionSets.Item("$Attribs$")

	If Err Then

	Err.Clear

	Set oSset = ThisDrawing.SelectionSets.Add("$Attribs$")

	End If

	

	On Error GoTo Err_Control

	

	oSset.SelectOnScreen dxftype, dxfdata

	'---------------------

	xlApp.Visible = True

	Set xlBook = xlApp.Workbooks.Add

	xlBook.Sheets.Add.Name = 1

	Set xlSheet = xlBook.Sheets(1)

	lngRow = 1

	xlSheet.Cells(lngRow, 1).Value = "Block Name"

	xlSheet.Rows(1).Font.Bold = True

	xlSheet.Rows(1).Font.ColorIndex = 5

	'---------------------

	lngRow = 2

	For Each oEnt In oSset

	

	Set oBlkRef = oEnt

	If oBlkRef.IsDynamicBlock Then

	xlSheet.Cells(lngRow, 1).Value = oBlkRef.EffectiveName

	Else

	xlSheet.Cells(lngRow, 1).Value = oBlkRef.Name

	End If

	varAtt = oBlkRef.GetAttributes

	lngCol = 2

	For i = 0 To UBound(varAtt)

	Set oAtt = varAtt(i)

	xlSheet.Cells(lngRow, lngCol).Value = oAtt.TagString

	xlSheet.Cells(lngRow + 1, lngCol).Value = oAtt.TextString

	lngCol = lngCol + 1

	

	Next i

	

	lngRow = lngRow + 2

	

	Next oEnt

	'--------------------

	Dim oRange As Range

	Set oRange = xlSheet.UsedRange

	For i = 2 To oRange.Columns.Count

	xlSheet.Cells(1, i).Value = "Attribue " & CStr(i - 1)

	Next

	'--------------------

	xlSheet.Columns.HorizontalAlignment = xlHAlignLeft

	xlSheet.Columns.AutoFit

	xlBook.SaveAs ThisDrawing.Path & "\Attributes.xls"

	xlBook.Close

	'--------------------

	xlApp.Application.Quit

	Set xlApp = Nothing

	Set xlBook = Nothing

	Set xlSheet = Nothing

	'--------------------

	MsgBox "Excel file was saved as: " & vbCr & ThisDrawing.Path & "\Attributes.xls"

	'--------------------

	Err_Control:

	

	End Sub[code]

[BIGAL]

I am working on something at the moment very slowly due to other commitments but sounds like what your after a more personalised version of dataextraction. Basically block name & attribute combos, but the number of attributes is a free variable it could be all or the 1st and 3rd etc. it does totals and sorts on the 1st two attributes so can have a "door" with paint colour and handle type as individual counts.

Can you post a sample dwg.

It may be easier to just create a CSV file then open in excel. There is lots of lisps about getting attributes of blocks and adding them up etc. Do a google. Pretty sure Lee-mac has a block count lisp.