Author Topic: Using AutoCad's ObjectDBX from Excel  (Read 12677 times)

0 Members and 1 Guest are viewing this topic.

Jeff_M

  • King Gator
  • Posts: 3945
  • C3D user & customizer
Re: Using AutoCad's ObjectDBX from Excel
« Reply #30 on: April 19, 2006, 12:17:37 PM »
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.
Code: [Select]
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

Viktor

  • Guest
Re: Using AutoCad's ObjectDBX from Excel
« Reply #31 on: April 20, 2006, 11:20:34 AM »
Welcome back Jeff. My issue is resolved with that error, let me try to post the whole thing.  you will also need the dwg, for it to work.
Bryco had a good idea to isolate just that error, because it seems if you do if err <> 0 then you will get tripped allot, odbx sends some type of error often, like error 20, i'm not sure why.

Ok, so, here's the files. I have another version with progress bar, but this one does not have it yet.
I will remove the attachments in a day or so, so go ahead and look at it.

and u know, i once had to drive for 36 hours to alaska with my brother, that was something i would not want to do again...
ok, it seems i can't add xls files. So here's the border and you should be able to just drop the code into a workbook and it would run.

Code: [Select]
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
    Dim X As Variant
   
'Last Empty Cell
    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


 
 'Check AutoCad Status
 Set acad = Nothing
    On Error Resume Next
    Set acad = GetObject(, "AutoCAD.Application")
    If Err <> 0 Then
        MsgBox "Please Start AutoCad and Click Again."
        Exit Sub
    End If
Set odbx = acad.GetInterfaceObject("ObjectDBX.AxDbDocument.16")


'Get Files
filetoopen = Application.GetOpenFilename("Drawing Files (*.dwg), *.dwg", , "Select Drawings", "Get Attributes", True)

If filetoopen <> False Then
Resume Next
Else: GoTo cancel
End If

'Each file process
On Error GoTo Errortrap
For Each Filename In filetoopen
'If Err.Number < 0 Then
'GoTo Errortrap
'Else: Resume Next
'End If

Continue:
RowNum = ActiveCell.Row

'Open dwg in odbx
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 InStr(UCase(blkref.Name), "CORP") > 0 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
                        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
              End If
           Next ent
          End If
        Next Layout
       
Resume_Here:
       
       Next Filename
   

   

    GoTo cancel


Errortrap:
Select Case Err.Number
        Case -2147467259   'Method 'Open' of object 'IAxDbDocument' failed
            X = X & vbCrLf & Filename
            Resume Resume_Here
        Case Else
        Err.Clear
 End Select
 Resume Resume_Here
   
cancel:

If Not IsEmpty(X) Then
MsgBox "Following files were not accessed: " & X
End If




'end all

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





just name a top left row "PROW1" you can name it by going to insert >name>define...
and make sure your worksheet is named "transmittal"
The rest should work.
Any advice is welcome :)

Thanks again Jeff!
and Thanks Bryco!

Jeff_M

  • King Gator
  • Posts: 3945
  • C3D user & customizer
Re: Using AutoCad's ObjectDBX from Excel
« Reply #32 on: April 20, 2006, 04:25:40 PM »
Bryco had a good idea to isolate just that error, because it seems if you do if err <> 0 then you will get tripped allot, odbx sends some type of error often, like error 20, i'm not sure why.
<snip>
Thanks again Jeff!
and Thanks Bryco!
You're welcome. FWIW, I don't think ODBX is throwing the error that you are getting......I rarely get any errors from ODBX......if it IS error 20, this isfrom the help as to what it means:
Quote
Trappable Errors
Trappable errors can occur while an application is running. Some trappable errors can also occur during development or compile time. You can test and respond to trappable errors using the On Error statement and the Err object. Unused error numbers in the range 1 1000 are reserved for future use by Visual Basic.

Code Message
<more snippage>
20 Resume without error
Which points me to the line:
Resume Resume_Here

This is the one located just after the Err handler......
Which gets executed at times when it really shouldn't be. Commenting out that line allowed it to work just fine for me, that is except for the ActiveSheet.Protect part. That part fails everytime, but after looking at the Excel help files it appears there are now more options available than there were in Excel 9.

Jeff