Code Red > VB(A)

ACAD 2017 - embedded images and perusing the drawing via OBDBX

(1/1)

Yosso:
Good afternoon all!

I'm still not comfortable enough with NET to work up solutions, so I've been muddling about with VBA.

Converted some code and merged some modules work get the attached workbook going...

Works great, but struggles with embedded raster images.  Pretty sure the CAD department is embedding using Raster Design, but I should verify.

The problematic file contains 0510 in the name...hence the debugging code.

I've managed to use some wonky error trapping to resume and pull the attributes from two of the three drawings which contain embedded raster images, but the last drawing is giving me fits, so I'd like to do it "right"

(Probably need to use c#...)

Code below and the actual workbook is attached. 

Using vanilla 2017 on my box.


--- Code - vb.net: ---' Determine if the chosen block is present in the drawingFor Each oBlock In oDBX.Blocks    If UCase(oBlock.Name) = UCase(gsBlockName) Then        BlkExist = True        If sPath Like "*0510*" Then            ' Debug.Print oBlock.Name            Stop        End If        Exit For    End IfNext oBlock ' Open each layout' Look for the title sheet block' If the block if found extract the attributesIf BlkExist Then    BlkFound = False    Set oLayouts = oDBX.Layouts    For Each oLayout In oLayouts        sngBlkCount = 0 ' reset the counter for each layout        ' If oLayout.Name = "0510" Then Stop        If oLayout.Name <> "Model" Then ' Paper Space            ' To Do : Add status bar update            ' Place the folder, file and layout name            ' into the Excel worksheet            ws.Cells(glRowCounter, 1) = fName            ws.Cells(glRowCounter, 2) = Right(sPath, Len(sPath) - InStrRev(sPath, "\"))            With ws.Cells(glRowCounter, 3)                .NumberFormat = "@"                .Value = oLayout.Name            End With            Set oBlock = oLayout.Block            For Each oEnt In oBlock'                If oLayout.Name = "0510" And (TypeOf oEnt Is AcadBlockReference) Then'                     Debug.Print oEnt.Effective.Name & " < - > " & oEnt.Name'                     'Stop'                     'Debug.Print oEnt.Name'                End If                ' On Error Resume Next              ' Raster image editing              ' http://forums.augi.com/showthread.php?88338-Remove-Raster-Image-VBA-Code'                If TypeOf oEnt Is AcadRasterImage Then'                    Stop'                End If                ' If Not (TypeOf oEnt Is AcadRasterImage Or TypeOf oEnt Is AcadExternalReference) Then                    If TypeOf oEnt Is AcadBlockReference Then  ' we have a block                        Set oBlockRef = oEnt                        If oLayout.Name = "0510" Then                            ' Stop                            Debug.Print oBlockRef.EffectiveName & "-" & oBlockRef.ObjectName                        End If                                                If oBlockRef.IsDynamicBlock Then                            BlkEffName = oBlockRef.EffectiveName                        Else                            BlkEffName = oBlockRef.Name                        End If                                                If BlkEffName = UCase(gsBlockName) Then ' We have found a matching block                            ' Place the block name in the Excel worksheet                            ws.Cells(glRowCounter, 4) = BlkEffName                            ' Place the current entity in a block reference                            Set oBlockRef = oEnt                            ' Increment the block counter - should only be a single                            ' instance of the title data block in the layout                            sngBlkCount = sngBlkCount + 1                            ' Does the block contain attributes?                            If oBlockRef.HasAttributes Then                                ' Extract the attributes from the block                                ' Parse the block's attributes                                blkAtts = oEnt.GetAttributes                                Call ExtractAtts(blkAtts, ws, glRowCounter, glColStart)                            End If                            ' Debug.Print oBlockRef.Name                        End If                    End If      ' AcadBlockReference                ' End If          ' AcadExternalReference                'End If ' xref            Next ' oEnt            If sngBlkCount = 0 Then ' block not found                ws.Cells(glRowCounter, 4) = "BLOCK NOT FOUND!"            End If            ' Increment the Excel rowcounter            glRowCounter = glRowCounter + 1        End IfReturn_xref:    Next ' oLayoutEnd If Return_Here: Resume_Cleanup: Exit Sub ' before error catch Error_Catch:Select Case Err.NumberCase -2147467259    MsgBox "The drawing """ & fFile & """ is open in this drawing session." & vbCrLf & _           "Please close and try again....", , "ObjectDBX Error"    Err.Clear    glRowCounter = glRowCounter + 1    Resume Return_HereCase -2147417851'    MsgBox "The drawing """ & fFile & """ has an embeded object." & vbCrLf & _'           "Unable to extract blocks at this time....", , "ObjectDBX Error"    Err.Clear    glRowCounter = glRowCounter + 1    Resume Return_xref  Case Else    MsgBox Err.Description & " - Error Number: " & Err.Number, , "Unhandled error"    Err.Clear    Resume Resume_CleanupEnd Select End Sub  

Navigation

[0] Message Index