脚本字典帮助

Option Explicit
Public objKeys As Variant
Public objItems As Variant
Public objDict As Dictionary
Public Sub DPW()
    Dim ent1 As AcadEntity
    Dim ent2 As AcadEntity
    Dim entXref As AcadExternalReference
    Dim entBlock As AcadBlock
    Dim entNestedBlock As AcadBlockReference
    Dim varAtts() As AcadAttributeReference
    Dim objBlock As AcadBlockReference
    Dim ssSet As AcadSelectionSet
    Dim FilterType(1) As Integer
    Dim FilterData(1) As Variant
    Dim obj As AcadEntity
    Dim i, x As Integer
    
    Set objDict = New Dictionary
    Set ssSet = vbdPowerSet("TEMP")
        
    FilterType(0) = 0
    FilterData(0) = "Insert"
    FilterType(1) = 2
    FilterData(1) = "*TEMP*"
    
    ssSet.Select acSelectionSetAll, , , FilterType, FilterData
    x = 1
    If ssSet.Count = 0 Then
        MsgBox "No blocks were found in this drawing!", vbInformation + vbOKOnly, "Quick Report"
        Exit Sub
    Else
        For Each obj In ssSet
            Set objBlock = obj
            If obj.HasAttributes Then
                varAtts = obj.GetAttributes
                For i = LBound(varAtts) To UBound(varAtts)
                
                    If UCase$(varAtts(i).TagString) = "ID" Then
                        If objDict.Exists(varAtts(i).TextString) = False Then
                            objDict.Add varAtts(i).TextString, 1
                        Else
                            objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
                        End If
                    End If
                    
                    If UCase$(varAtts(i).TagString) = "NUMBER" Then
                        If objDict.Exists(varAtts(i).TextString) = False Then
                            objDict.Add varAtts(i).TextString, 1
                        Else
                            objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
                        End If
                    End If
                    
                    If UCase$(varAtts(i).TagString) = "LOCATION" Then
                        If objDict.Exists(varAtts(i).TextString) = False Then
                            objDict.Add varAtts(i).TextString, 1
                        Else
                            objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
                        End If
                    End If
                    
                    
                    If UCase$(varAtts(i).TagString) = "COLOR" Then
                        If objDict.Exists(varAtts(i).TextString) = False Then
                            objDict.Add varAtts(i).TextString, 1
                        Else
                            objDict.Item(varAtts(i).TextString) = objDict.Item(varAtts(i).TextString) + 1
                        End If
                    End If
                    On Error GoTo 0
                Next i
            End If
        Next obj
        i = 0
        
        objKeys = objDict.Keys
        BubbleSort objKeys
        objItems = objDict.Items
        
        Dim filenum As Integer
        Dim strLine1 As String
        
        For x = 0 To UBound(objKeys)
            Debug.Print objKeys(x) & vbTab & vbTab & objDict(objKeys(x))
            i = i + objItems(x)
        Next
    End If
End Sub
Public Function vbdPowerSet(strName As String) As AcadSelectionSet
    Dim objSelSet As AcadSelectionSet
    Dim objSelCol As AcadSelectionSets
    
    Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
        If objSelSet.Name = strName Then
            objSelSet.Delete
            Exit For
        End If
    Next
    Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
    Set vbdPowerSet = objSelSet
End Function
Sub BubbleSort(arr As Variant, Optional descending As Boolean, Optional numEls As Variant)
' Bubble Sort an array of any type
' Author: The VB2TheMax Team
' BubbleSort is especially convenient with small arrays (1,000
' items or fewer) or with arrays that are already almost sorted
'
' NUMELS is the index of the last item to be sorted, and is
' useful if the array is only partially filled.
'
' Works with any kind of array, except UDTs and fixed-length
' strings, and including objects if your are sorting on their
' default property. String are sorted in case-sensitive mode.
'
' You can write faster procedures if you modify the first two lines
' to account for a specific data type, eg.
' Sub BubbleSortS(arr() As Single, Optional descending As Boolean, Optional numEls As Variant)
'   Dim value As Single
    Dim Value As Variant
    Dim Index As Long
    Dim firstItem As Long
    Dim indexLimit As Long, lastSwap As Long
    ' account for optional arguments
    If IsMissing(numEls) Then numEls = UBound(arr)
    firstItem = LBound(arr)
    lastSwap = numEls
    Do
        indexLimit = lastSwap - 1
        lastSwap = 0
        For Index = firstItem To indexLimit
            Value = arr(Index)
            If (Value > arr(Index + 1)) Xor descending Then
                ' if the items are not in order, swap them
                arr(Index) = arr(Index + 1)
                arr(Index + 1) = Value
                lastSwap = Index
            End If
        Next
    Loop While lastSwap
End Sub