Well, here's the code, its not as smooth as i want it to be, maybe over the weekend i will have some time to mess around with it.
Public acad As Object
Public odbx As Object
Public mspace As Object
Public excel As Object
Public AcadRunning As Integer
Public excelSheet As Object
Sub Extract()
ActiveSheet.Unprotect
Dim sheet As Object
Dim shapes As Object
Dim excel As Object
Dim excelSheet As Object
Dim RowNum As Integer
Dim Array1 As Variant
Dim i As Integer
Dim ent As AcadEntity
Dim Layouts As AcadLayouts
Dim Layout As AcadLayout
Dim blkref As AcadBlockReference
Dim filetoopen As Variant
Dim tag5 As String
'Prepare Excel
Set excelSheet = ActiveWorkbook.Sheets("transmittal")
Range("prow1").Select
Do
If IsEmpty(ActiveCell) = False Then
ActiveCell.Offset(1, 0).Select
End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.Offset(-1, 0).Select
'getfilenames
filetoopen = Application.GetOpenFilename("Drawing Files (*.dwg), *.dwg", , "Select Drawings", "Get Attributes", True)
RowNum = ActiveCell.Row
On Error Resume Next
Set acad = GetObject(, "AutoCAD.Application")
If Err <> 0 Then
Set acad = CreateObject("AutoCAD.Application")
End If
On Error GoTo 0
Set odbx = acad.GetInterfaceObject("ObjectDBX.AxDbDocument.16")
For Each Filename In filetoopen
odbx.Open Filename
'Work in AutoCad
Set Layouts = odbx.Layouts
For Each Layout In Layouts
If Layout.Name <> "Model" Then
For Each ent In Layout.Block
If ent.ObjectName = "AcDbBlockReference" Then
Set blkref = ent
If blkref.Name = "CORP-D" Then
Array1 = blkref.GetAttributes
RowNum = RowNum + 1
For i = LBound(Array1) To UBound(Array1)
If Array1(i).TagString = "7" Then
excelSheet.Cells(RowNum, 2).Value = Array1(i).TextString
End If
If Array1(i).TagString = "8" Then
excelSheet.Cells(RowNum, 4).Value = "Rev. " & Array1(i).TextString
End If
If Array1(i).TagString = "5" Then
tag5 = Array1(i).TextString
'excelSheet.Cells(RowNum, 2).Value = Array1(i).TextString
End If
If Array1(i).TagString = "6" Then
excelSheet.Cells(RowNum, 5).Value = tag5 & " " & Array1(i).TextString
End If
If Array1(i).TagString = "1" Then
excelSheet.Cells(RowNum, 8).Value = Array1(i).TextString
End If
Next i
End If 'blkref
End If 'ent
Next ent 'each ent
End If 'layout
Next Layout
Next Filename
Set acad = Nothing
Set odbx = Nothing
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
:=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
AllowUsingPivotTables:=True
End Sub
Thanks allot to Jeff, great tips and advice!
Viktor.