ObjectDBX-动态块和有效名称。。。
有#039；这是一个电子表格工具，可在AUGI论坛上使用，它将打开一个图纸文件夹，从图纸中拉出块，并用属性填充excel表 ；如果你不'；t有动态块秘制酱汁与；有效名称；但我'；我很难理解如何获得块的有效名称
此处'；代码摘录：
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
此处#039；s错误编号和描述：
如有任何帮助，将不胜感激
由于并没有看到更多相关的代码，我不能说我理解你们展示的代码的确切目的
然而，预计会出现错误消息：；对于每个……”；回路穿过图纸#039；s块定义，以查看图形中是否存在块定义
因此，MyBlock声明为AcadBlock，而不是AcadBlockreference，因此为MyBlock。EffectiveName错误并引发异常
块定义（无论是否为动态块）总是有一个名称，而块引用（如果为动态块引用）可以有一个；注释性块“；因此，名称是只读的；有效名称；需要指示从哪个动态块定义派生
很明显，你得到的工具在处理动态块时有一个bug。 对，该工具具有；动态块的问题   
非常感谢您对有效名称的解释
我试图修改现有代码，但尚未成功，但正在取得进展（见下文）
刚刚购买了Jerry Winter的VB.net书籍，可能会尝试VB.net方法
此处'；s是原始代码（适用于非动态块）
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.Number0 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
谢谢你的帮助。 取得进展后，通过对原始VBA代码的一些修改，能够找到并提取带有属性的动态块
下一步是提取图形中块实例的动态特性和句柄
谢谢你的阅读 
M.
页:
[1]