TheSwamp
Code Red => VB(A) => Topic started by: Yosso on February 16, 2014, 12:00:54 AM
-
There's a spreadsheet tool that is available on the AUGI forum (http://forums.augi.com/showthread.php?86113-VBA-and-ObjectDbx-AutoCAD-to-Excel-Attribute-Extraction-Tool/page5) which will open up a folder of drawings and pull out blocks from the drawings and populate the excel sheet with the attributes. Works great, if you don't have dynamic blocks.
The secret sauce is related to the "EffectiveName" of the block, but I'm having trouble understanding how to get the effective name of the block.
Here's the code excerpt:
For Each MyBlock In MyDbx.Blocks
If MyBlock.IsDynamicBlock Then
If UCase(MyBlock.EffectiveName) = UCase(Range("BlkName").Value) Then
BlkExist = True
Exit For
End If
End If
If UCase(MyBlock.Name) = UCase(Range("BlkName").Value) Then
BlkExist = True
Exit For
End If
Next MyBlock
Here's the error number and description:
Error #438
Object doesn't support this property or method
Any assistance would be greatly appreciated. :-D
-
Not seeing more related code, I could not say I understand exact purpose of the code you showed.
However, the error message is expected:
The "For Each..." loop goes through a drawing's block definitions to see whether a block definition exists in drawing.
So, MyBlock as declared as AcadBlock, not AcadBlockreference, therefore, MyBlock.EffectiveName is wrong and raises the exception.
A block definition, be it dynamic block or not, always has a name, while a block reference, if being a dynamic block reference, could have an "annomynous block" name, thus, a read-only "EffectiveName" is needed to indicate from which dynamic block definition it is derived.
It is obvious that the tool you get has a bug when dealing with dynamic block.
-
Right, the tool has a problem with Dynamic blocks. :-D
I do appreciate the explanation of the Effective name.
I am trying to modify the existing code, but have yet to be successful, but am making progress (see below).
Just purchased the Jerry Winter VB.net book, going to try the VB.net approach, maybe.
Here's the original code (which works just fine with non-dynamic blocks).
Sub GetBlockInfo()
Dim DwgCnt As Integer
Dim DwgName As String
Dim StrPath As String
Dim BlkExist As Boolean
Dim intType(1) As Integer
Dim varData(1) As Variant
Dim BlkFound As Boolean
Dim AttTitles As Boolean
Dim ChkSht As Worksheet, DwgLstSht As Worksheet
Dim MyDbx As AxDbDocument
Dim MyLayouts As AcadLayouts
Dim MyLayout As Variant
Dim MyEnt As AcadEntity
Dim MyBlock As AcadBlock
Dim MyBlockR As AcadBlockReference
Dim MyAtt As AcadAttributeReference
Dim AttCt1, AttCt2 As Integer
Dim Atts As Variant
Dim MyBlkCount As Integer
Set DwgLstSht = Sheets("DrawingList")
Set ChkSht = Sheets("CheckList")
GetFileNames
' Set up error control
On Error GoTo Error_Control
Init ' initialize global variables
' Get the Current Path
StrPath = ThisWorkbook.Path
If (Right(StrPath, 1) <> "\") Then
StrPath = StrPath & "\"
End If
' Unprotect sheet for drawing modifications
DwgLstSht.Unprotect
ChkSht.Unprotect
' Replace the Layout header since it was deleted when the attributes where cleared
DwgLstSht.Cells(ROWOFF - 1, 2) = "Layout"
' Get the first drawing in the list and store in DwgName
DwgCnt = 0
AttTitles = False ' Set the Attribute Titles Flag to False (no titles yet)
DwgName = DwgLstSht.Cells(DwgCnt + ROWOFF, 1)
' Call display status function
temp = Status_Bar(True, "Activating ObjectDBX...")
Set MyDbx = GetInterfaceObject("ObjectDBX.AxDbDocument.18")
While DwgName <> ""
' Call Display Status Function
temp = Status_Bar(True, "Opening drawing " & DwgName)
' Open a drawing in ObjectDbx
Set MyDbx = dbxOpen(StrPath, DwgName)
' If there are no errors and there is a file open
If Err.Number = 0 And MyDbx.Name <> "" Then
' Determine if the chosen block is present in the drawing
For Each MyBlock In MyDbx.Blocks
If UCase(MyBlock.Name) = UCase(Range("BlkName").Value) Then
BlkExist = True
Exit For
End If
Next MyBlock
' If the block was found , then proceed
If BlkExist Then
BlkFound = False
MyBlkCount = 0
' Iterate through all Layouts
Set MyLayouts = MyDbx.Layouts
For Each MyLayout In MyDbx.Layouts
' Avoid Modelspace if the Check Modelspace checkbox is NOT checked
If Sheets("DrawingList").Model_Check.Value Or MyLayout.Name <> "Model" Then
' Call display status function
temp = Status_Bar(True, "Searching " & DwgName & " Layout " & MyLayout.Name & " " & Range("BlkName").Value)
' Loop through each entity in the layout.block group
For Each MyEnt In MyLayout.Block
' Check if the current Entity is a Block Reference
If TypeOf MyEnt Is AcadBlockReference Then
' Check that the block name matches what we are looking for
If UCase(MyEnt.Name) = UCase(Range("BlkName").Value) Then
' Store the current Entity as a Block Reference
Set MyBlockR = MyEnt
' Make sure that the Block Reference has attributes
If MyBlockR.HasAttributes Then
' If we have already found a block in the current drawing, add another row
If MyBlkCount > 0 Then
DwgLstSht.Cells(DwgCnt + ROWOFF + 1, 1).EntireRow.Insert
DwgCnt = DwgCnt + 1
DwgLstSht.Cells(DwgCnt + ROWOFF, 1) = DwgName
ChkSht.Cells(DwgCnt + ROWOFF, 1) = DwgName
End If
DwgLstSht.Cells(DwgCnt + ROWOFF, 2) = MyLayout.Name
ChkSht.Cells(DwgCnt + ROWOFF, 2) = MyLayout.Name
' Store all attributes in the matrix Atts
Atts = MyEnt.GetAttributes
' Step through each attribute in Atts
For AttCt1 = LBound(Atts) To UBound(Atts)
' Get the next attribute
Set MyAtt = Atts(AttCt1)
' Call Display Status Function
temp = Status_Bar(True, "Accessing " & DwgName & " attributes: " & MyAtt.TagString & ".")
' Write the attribute information to DrawingList and CheckList sheets
DwgLstSht.Cells(DwgCnt + ROWOFF, AttCt1 + COLOFF).NumberFormat = "@" 'C. White 27/09/11 added to ensure attribute is listed as a string in Excel
DwgLstSht.Cells(DwgCnt + ROWOFF, AttCt1 + COLOFF) = MyAtt.TextString
ChkSht.Cells(DwgCnt + ROWOFF, AttCt1 + COLOFF) = MyAtt.TextString
' If this is the first drawing, store the attribute tags in the header row
If AttTitles = False Then
DwgLstSht.Cells(ROWOFF - 1, AttCt1 + COLOFF) = MyAtt.TagString
ChkSht.Cells(ROWOFF - 1, AttCt1 + COLOFF) = MyAtt.TagString
If AttCt1 = UBound(Atts) Then
AttTitles = True
End If
End If
Next AttCt1
MyBlkCount = MyBlkCount + 1
End If
Exit For
End If
End If
Next
End If
Next
End If
' Clean the mydbx variable
Set MyDbx = Nothing
ElseIf Err.Number = 0 And MyDbx.Name = "" Then
' Turn off the Status bar
temp = Status_Bar(False)
Exit Sub
End If
' Clean up Variables
Set MyBlock = Nothing
Set MyBlockR = Nothing
Set MyAtt = Nothing
DwgCnt = DwgCnt + 1
DwgName = Cells(DwgCnt + ROWOFF, 1)
Wend
Error_Control:
If Err.Number <> 0 Then
Set MyBlock = Nothing
Set MyAtt = Nothing
If Err.Number = 13 Then
MsgBox "Failed to initiate ObjectDbx, probably due to another version of Autocad...", vbCritical, "ObjectDBX Fail"
Else
MsgBox "Error #" & Err.Number & vbCr & Err.Description
End If
End If
If Not MyDbx Is Nothing Then Set MyDbx = Nothing
' Adjust column widths to match the data in the cells
DwgLstSht.Activate
DwgLstSht.Columns.AutoFit
DwgLstSht.Cells(4, 2) = Now
DwgLstSht.Range("A6").Select
' Protect sheet
DwgLstSht.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
ChkSht.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
' Turn off the Status bar
temp = Status_Bar(False)
End Sub
Thanks for the bump.
M.
-
Making progress, was able to find and extract the dynamic blocks with their attributes with a few modifications to the original VBA code.
Next step is to extract the dynamic properties and the handle of the block instances in the drawings.
Thank you for reading. :-)
M.