Export attribute data from multiple drawings

[Wesley_Amsterdam]

Hi all,

 

Since 2007 I've used a tool which could export all attribute data to excel, adjust the data and update it right back into Autocad.

This was all done via VBA.

Unfortunally the code has never been updated and now it is not working anymore.

 

I use this tool very often, and I really hope to get it working again.

Or maybe something similar.

 

Workflow should be as follows:

 

-Run the command (export block information to excel)

(Opens excel in the background)

-select a block

-Programm will check all drawings (the drawings which are open in the autocad session) if the block is there.

-Then export all attribute information to Excel.

 

The second programm will update all attributes in all open drawings.

 

Who can help me ???

 

Regards,

Wesley

[MSasu]

It is possible that your tool stopped working since VBA is no longer supported by default in newer releases of AutoCAD; however you may download an enabler extension from Autodesk.

[Wesley_Amsterdam]

I have the vba enabler installed for all of my versions.

Somehow it is not working anymore.

And in Acad2014 the 32bit code is not wokring anymore.

 

I'm not a vba programmer so I cant find the problem.

[BIGAL]

Is it open code or has it been compiled ? If compiled then trying to run in 64 bit may be the problem.

 

Do you have the source code ? the use Vbaman to test you can run from command line a DVB Use: ^C^C(vl-vbaload "S:/VBA/Design Toolkit.dvb") (vl-vbarun "ToolKit")

[Wesley_Amsterdam]

Well I was more wondering if this also is possible via LISP.

[Spaj]

Hi

 

Have you looked at Lee McDonald's routine/s:

 

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

[MSasu]

export all attribute data to excel, adjust the data and update it right back into Autocad.

This was only one operation, with "adjust the data" meaning doing calculations in Excel before updating the attributes? Or were about 2 separate actions/commands (export / import)?

 

 

Basically, to address your last question, you can extract/edit attributes by AutoLISP and also access Excel via COM technology, so it seems feasible to replicate your tool.

[Wesley_Amsterdam]

Macatt will only let me export the attribute values.

What i am looking for is:

-To select a titleblock,

-export all of the attribute values of all open drawings to excel,

-update the information (like drawingnumbers - drawingtitles)

-import it back into autocad.

 

@BIGAL

I had a look at the vba code. But it look likes it uses a lot of different parts.

[BIGAL]

If your happy post the code it sounds like its not compiled then someone can try to run and find the problem. May be simpler than starting again. Then its easier even to rewrite it if needed.

[Wesley_Amsterdam]

I don't know if this is all of the code.

This is just a part of it all.

There is a massive amount of little tools in the dvb-file.

 

Hope you can do something with it BIGAL.

 

Public Sub TelAllDocs()
Dim aDocs As Variant, aDoc As AcadDocument
Dim oBlok As AcadBlockReference, Pt
Dim Excel As Object, ExcelSheet As Object
Dim nX
Dim EersteRij() As Variant

   Debug.Print
   
   Set Excel = StartExcel
   Excel.Visible = True
   Excel.Workbooks.Add
   Set ExcelSheet = Excel.sheets.Add
   ExcelSheet.name = Format(Application.Documents.Count, "00") & "-documenten"
   RowNum = 2
   
   EersteRij = Array("Bloknaam", "X", "Y", "Handle", "Layer", "Pad", "Filenaam")
   
   ExcelSheet.Range("A1:BZ1").Font.Bold = True

   For nX = LBound(EersteRij) To UBound(EersteRij)
       ExcelSheet.cells(1, nX + 1).Value = EersteRij(nX)
   Next nX
   
   AppActivate "Autocad", False
   DoEvents
   On Error Resume Next
   ThisDrawing.Utility.GetEntity oBlok, Pt, "Wijs Blok aan : "
   If Err.Number <> 0 Then Exit Sub
   On Error GoTo 0
   
   Set aDocs = Application.Documents
   
   For Each aDoc In aDocs
       Debug.Print aDoc.Path; "\"; aDoc.name
       aDoc.Activate
       TelAttrDoc oBlok.name
   Next
   Beep
   Set Excel = Nothing
   Set ExcelSheet = Nothing
   
End Sub

Private Sub TelAttrDoc(sBlokNaam)
Dim Excel As Object
Dim oBlokje As Object
Dim ExcelSheet As Object
Dim Array1 As Variant
Dim Count
Dim NumberOfAttributes As Integer
Dim FoundAttributes As Boolean
Dim tmp As Integer
Dim oBlokjeReference As AcadBlockReference
Dim sBlokName As String
Dim nKol1, nX, Retval As Double, nTimeout As Byte
Dim EersteRij() As Variant

Dim W9 As AcadSelectionSet
Dim Q4 As cObj
   Set Q4 = New cObj
   Q4.VoegToeGroepModified BLOK, Left(sBlokNaam, 7) & "*"
   Q4.SelType = acSelectAll
   Q4.ExcecuteSelect
   
   Set W9 = ThisDrawing.SelectionSets(Q4.SelSetNaam)
   Debug.Print W9.Count
   If W9.Count = 0 Then Exit Sub
   
   nTagTeller = 0

   Set Excel = StartExcel
   Set ExcelSheet = Excel.sheets(Format(Application.Documents.Count, "00") & "-documenten")
   
   On Error GoTo 0

   EersteRij = Array("", "", "", "", "", "", "")
   
   For Each oBlokje In W9
       If oBlokje.HasAttributes Then
           Set oBlokjeReference = oBlokje
               ExcelSheet.cells(RowNum, 1) = oBlokje.name
               ExcelSheet.cells(RowNum, 1).NumberFormat = "@"
               ExcelSheet.cells(RowNum, 2).Value = oBlokjeReference.InsertionPoint(0)
               ExcelSheet.cells(RowNum, 3).Value = oBlokjeReference.InsertionPoint(1)
               ExcelSheet.cells(RowNum, 4).NumberFormat = "@"
               ExcelSheet.cells(RowNum, 4).Value = oBlokjeReference.Handle
               ExcelSheet.cells(RowNum, 5).Value = oBlokjeReference.Layer
               ExcelSheet.cells(RowNum, 6).Value = ThisDrawing.GetVariable("dwgprefix")
               ExcelSheet.cells(RowNum, 7).Value = ThisDrawing.GetVariable("dwgname")
               Array1 = oBlokjeReference.GetAttributes
               For Count = LBound(Array1) To UBound(Array1)
                   nKol1 = WelkeKolomMod(Trim(Array1(Count).TagString), ExcelSheet, UBound(EersteRij) + 1)
                   ExcelSheet.cells(RowNum, nKol1).NumberFormat = "@"
                   ExcelSheet.cells(RowNum, nKol1).Value = Trim(Array1(Count).TextString)
               Next Count
               RowNum = RowNum + 1
       End If
   Next oBlokje
   Set Excel = Nothing
   Set ExcelSheet = Nothing
End Sub

 

And sorry for the Dutch language in it. :-)