OK, I'm finally back in action. My brother-in-law & I ended up driving a moving van from Watkins Glen, NY to Santa Rosa, CA in roughly 48 hours........not a trip I want to make again.
Can you post your code that you've tried to work over this error? This is what I came up with that should allow it to run without error. Could you post the Excel workbook that you use? (I don't use excel enough to even know how to create that Range you reference.....) The only errors I get with this code are those raised due to Excel coding which may be induced by me only having Excel2000.
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 filename As Variant
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.16")
End If
On Error GoTo 0
Set odbx = acad.GetInterfaceObject("ObjectDBX.AxDbDocument.16")
For Each filename In filetoopen
On Error Resume Next
odbx.Open filename
If Err Then
Err.Clear
Debug.Print filename
GoTo Resume_Here
End If
On Error GoTo 0
'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)
Select Case Array1(i).TagString
Case Is = "7"
excelSheet.Cells(RowNum, 2).Value = Array1(i).TextString
Case Is = "8"
excelSheet.Cells(RowNum, 4).Value = "Rev. " & Array1(i).TextString
Case Is = "5"
tag5 = Array1(i).TextString
'excelSheet.Cells(RowNum, 2).Value = Array1(i).TextString
Case Is = "6"
excelSheet.Cells(RowNum, 5).Value = tag5 & " " & Array1(i).TextString
Case Is = "1"
excelSheet.Cells(RowNum, 8).Value = Array1(i).TextString
End Select
Next i
Exit For
End If 'blkref
End If 'ent
Next ent 'each ent
End If 'layout
Next Layout
Resume_Here:
Next filename
Set odbx = Nothing
Set acad = 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