动态块和有效名称...

 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

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