' Determine if the chosen block is present in the drawing
For Each oBlock In oDBX.Blocks
BlkExist = True
If sPath Like "*0510*" Then
' Debug.Print oBlock.Name
Stop
End If
Exit For
End If
Next oBlock
' Open each layout
' Look for the title sheet block
' If the block if found extract the attributes
If 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 If
Return_xref:
Next ' oLayout
End If
Return_Here:
Resume_Cleanup:
Exit Sub ' before error catch
Error_Catch:
Select Case Err.Number
Case -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_Here
Case -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_Cleanup
End Select
End Sub