动态块和有效名称...
AUGI论坛上有一个电子表格工具，它将打开一个图形文件夹，并从图形中提取块，并用属性填充excel工作表。 如果你没有动态块，效果很好。秘诀与块的“有效名称”有关，但我很难理解如何获取块的有效名称。
以下是代码摘录：
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
这是错误号和描述：
任何帮助将不胜感激。
**** Hidden Message ***** 没有看到更多相关的代码，我不能说我理解你显示的代码的确切目的。
但是，错误消息是预期的：
“对于每个...”循环遍历图形的块定义，以查看图形中是否存在块定义。
因此，MyBlock 声明为 AcadBlock，而不是 AcadBlockreference，因此，MyBlock.EffectiveName 是错误的，并引发了异常。
块定义，无论是否是动态块，总是有一个名称，而块引用，如果是动态块引用，可以有一个“异常块”名称，因此，需要一个只读的“EffectiveName”来指示它从哪个动态块定义派生出来。
很明显，您在处理动态块时获得的工具存在错误。 没错，这个工具对动态块有问题。
我非常感谢对有效名称的解释。
我正在尝试修改现有代码，但尚未成功，但正在取得进展(见下文)。
刚买了杰里·温特·VB.net的书，可能会尝试VB.net的方法。
下面是原始代码(它适用于非动态块)。
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
谢谢你的鼓励。
M 在取得进展的同时，它能够找到并提取动态块及其属性，只需对原始VBA代码进行一些修改
下一步是提取图形中块实例的动态特性和句柄
M.
页:
[1]