环境影响评价工程师-环境影响评价相关法律法规-第一章 概论-第一节 环境和环境影响评价

类模块

''
' Dictionary v1.2.0
' (c) Tim Hall - https://github.com/timhall/VBA-Dictionary
'
' Drop-in replacement for Scripting.Dictionary on Mac
'
' @author: tim.hall.engr@gmail.com
' @license: MIT (http://www.opensource.org/licenses/mit-license.php
'
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
Option Explicit

' --------------------------------------------- '
' Constants and Private Variables
' --------------------------------------------- '

#Const UseScriptingDictionaryIfAvailable = True

#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    
    ' KeyValue 0: FormattedKey, 1: OriginalKey, 2: Value
    Private pKeyValues As Collection
    Private pKeys() As Variant
    Private pItems() As Variant
    Private pCompareMode As CompareMethod
    
#Else
    
    Private pDictionary As Object
    
#End If

' --------------------------------------------- '
' Types
' --------------------------------------------- '

Public Enum CompareMethod
    BinaryCompare = vbBinaryCompare
    TextCompare = vbTextCompare
    DatabaseCompare = vbDatabaseCompare
End Enum

' --------------------------------------------- '
' Properties
' --------------------------------------------- '

Public Property Get CompareMode() As CompareMethod
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        CompareMode = pCompareMode
    #Else
        CompareMode = pDictionary.CompareMode
    #End If
End Property
Public Property Let CompareMode(Value As CompareMethod)
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        If Me.Count > 0 Then
            ' Can't change CompareMode for Dictionary that contains data
            ' http://msdn.microsoft.com/en-us/library/office/gg278481(v=office.15).aspx
            ERR.Raise 5 ' Invalid procedure call or argument
        End If
        
        pCompareMode = Value
    #Else
        pDictionary.CompareMode = Value
    #End If
End Property

Public Property Get Count() As Long
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Count = pKeyValues.Count
    #Else
        Count = pDictionary.Count
    #End If
End Property

Public Property Get Item(Key As Variant) As Variant
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Dim KeyValue As Variant
        KeyValue = GetKeyValue(Key)
        
        If Not IsEmpty(KeyValue) Then
            If IsObject(KeyValue(2)) Then
                Set Item = KeyValue(2)
            Else
                Item = KeyValue(2)
            End If
        Else
            ' Not found -> Returns Empty
        End If
    #Else
        If IsObject(pDictionary.Item(Key)) Then
            Set Item = pDictionary.Item(Key)
        Else
            Item = pDictionary.Item(Key)
        End If
    #End If
End Property
Public Property Let Item(Key As Variant, Value As Variant)
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        If Me.Exists(Key) Then
            ReplaceKeyValue GetKeyValue(Key), Key, Value
        Else
            AddKeyValue Key, Value
        End If
    #Else
        pDictionary.Item(Key) = Value
    #End If
End Property
Public Property Set Item(Key As Variant, Value As Variant)
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        If Me.Exists(Key) Then
            ReplaceKeyValue GetKeyValue(Key), Key, Value
        Else
            AddKeyValue Key, Value
        End If
    #Else
        Set pDictionary.Item(Key) = Value
    #End If
End Property

Public Property Let Key(Previous As Variant, Updated As Variant)
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Dim KeyValue As Variant
        KeyValue = GetKeyValue(Previous)
        
        If Not IsEmpty(KeyValue) Then
            ReplaceKeyValue KeyValue, Updated, KeyValue(2)
        End If
    #Else
        pDictionary.Key(Previous) = Updated
    #End If
End Property

' ============================================= '
' Public Methods
' ============================================= '

''
' Add an item with the given key
'
' @param {Variant} Key
' @param {Variant} Item
' --------------------------------------------- '
Public Sub Add(Key As Variant, Item As Variant)
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        If Not Me.Exists(Key) Then
            AddKeyValue Key, Item
        Else
            ' This key is already associated with an element of this collection
            ERR.Raise 457
        End If
    #Else
        pDictionary.Add Key, Item
    #End If
End Sub

''
' Check if an item exists for the given key
'
' @param {Variant} Key
' @return {Boolean}
' --------------------------------------------- '
Public Function Exists(Key As Variant) As Boolean
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Exists = Not IsEmpty(GetKeyValue(Key))
    #Else
        Exists = pDictionary.Exists(Key)
    #End If
End Function

''
' Get an array of all items
'
' @return {Variant}
' --------------------------------------------- '
Public Function Items() As Variant
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        If Me.Count > 0 Then
            Items = pItems
        Else
            ' Split("") creates initialized empty array that matches Dictionary Keys and Items
            Items = Split("")
        End If
    #Else
        Items = pDictionary.Items
    #End If
End Function

''
' Get an array of all keys
'
' @return {Variant}
' --------------------------------------------- '
Public Function Keys() As Variant
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        If Me.Count > 0 Then
            Keys = pKeys
        Else
            ' Split("") creates initialized empty array that matches Dictionary Keys and Items
            Keys = Split("")
        End If
    #Else
        Keys = pDictionary.Keys
    #End If
End Function

''
' Remove an item for the given key
'
' @param {Variant} Key
' --------------------------------------------- '
Public Sub Remove(Key As Variant)
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Dim KeyValue As Variant
        KeyValue = GetKeyValue(Key)
        
        If Not IsEmpty(KeyValue) Then
            RemoveKeyValue KeyValue
        Else
            ' Application-defined or object-defined error
            ERR.Raise 32811
        End If
    #Else
        pDictionary.Remove Key
    #End If
End Sub

''
' Remove all items
' --------------------------------------------- '
Public Sub RemoveAll()
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Set pKeyValues = New Collection
        
        Erase pKeys
        Erase pItems
    #Else
        pDictionary.RemoveAll
    #End If
End Sub

' ============================================= '
' Private Functions
' ============================================= '

#If Mac Or Not UseScriptingDictionaryIfAvailable Then
    
    Private Function GetKeyValue(Key As Variant) As Variant
        On Error Resume Next
        GetKeyValue = pKeyValues(GetFormattedKey(Key))
        ERR.Clear
    End Function
    
    Private Sub AddKeyValue(Key As Variant, Value As Variant, Optional Index As Long = -1)
        If Me.Count = 0 Then
            ReDim pKeys(0 To 0)
            ReDim pItems(0 To 0)
        Else
            ReDim Preserve pKeys(0 To UBound(pKeys) + 1)
            ReDim Preserve pItems(0 To UBound(pItems) + 1)
        End If
        
        Dim FormattedKey As String
        FormattedKey = GetFormattedKey(Key)
        
        If Index > 0 And Index <= pKeyValues.Count Then
            Dim i As Long
            For i = UBound(pKeys) To Index Step -1
                pKeys(i) = pKeys(i - 1)
                If IsObject(pItems(i - 1)) Then
                    Set pItems(i) = pItems(i - 1)
                Else
                    pItems(i) = pItems(i - 1)
                End If
            Next i
            
            pKeys(Index - 1) = Key
            If IsObject(Value) Then
                Set pItems(Index - 1) = Value
            Else
                pItems(Index - 1) = Value
            End If
            
            pKeyValues.Add Array(FormattedKey, Key, Value), FormattedKey, before:=Index
        Else
            pKeys(UBound(pKeys)) = Key
            If IsObject(Value) Then
                Set pItems(UBound(pItems)) = Value
            Else
                pItems(UBound(pItems)) = Value
            End If
            
            pKeyValues.Add Array(FormattedKey, Key, Value), FormattedKey
        End If
    End Sub
    
    Private Sub ReplaceKeyValue(KeyValue As Variant, Key As Variant, Value As Variant)
        Dim Index As Long
        Dim i As Integer
        
        For i = 0 To UBound(pKeys)
            If pKeys(i) = KeyValue(1) Then
                Index = i + 1
                Exit For
            End If
        Next i
        
        ' Remove existing value
        RemoveKeyValue KeyValue, Index
        
        ' Add new key value back
        AddKeyValue Key, Value, Index
    End Sub
    
    Private Sub RemoveKeyValue(KeyValue As Variant, Optional ByVal Index As Long = -1)
        Dim i As Long
        If Index = -1 Then
            For i = 0 To UBound(pKeys)
                If pKeys(i) = KeyValue(1) Then
                    Index = i
                End If
            Next i
        Else
            Index = Index - 1
        End If
        
        If Index >= 0 And Index <= UBound(pKeys) Then
            For i = Index To UBound(pKeys) - 1
                pKeys(i) = pKeys(i + 1)
                
                If IsObject(pItems(i + 1)) Then
                    Set pItems(i) = pItems(i + 1)
                Else
                    pItems(i) = pItems(i + 1)
                End If
            Next i
            
            If UBound(pKeys) = 0 Then
                Erase pKeys
                Erase pItems
            Else
                ReDim Preserve pKeys(0 To UBound(pKeys) - 1)
                ReDim Preserve pItems(0 To UBound(pItems) - 1)
            End If
        End If
        
        pKeyValues.Remove KeyValue(0)
    End Sub
    
    Private Function GetFormattedKey(Key As Variant) As String
        GetFormattedKey = CStr(Key)
        If Me.CompareMode = CompareMethod.BinaryCompare Then
            ' Collection does not have method of setting key comparison
            ' So case-sensitive keys aren't supported by default
            ' -> Approach: Append lowercase characters to original key
            '    AbC -> AbC__b, abc -> abc__abc, ABC -> ABC
            '    Won't work in very strange cases, but should work for now
            '    AbBb -> AbBb__bb matches AbbB -> AbbB__bb
            Dim Lowercase As String
            Lowercase = ""
            
            Dim i As Integer
            Dim Ascii As Integer
            Dim Char As String
            For i = 1 To Len(GetFormattedKey)
                Char = VBA.Mid$(GetFormattedKey, i, 1)
                Ascii = Asc(Char)
                If Ascii >= 97 And Ascii <= 122 Then
                    Lowercase = Lowercase & Char
                End If
            Next i
            
            If Lowercase <> "" Then
                GetFormattedKey = GetFormattedKey & "__" & Lowercase
            End If
        End If
    End Function
    
#End If

Private Sub Class_Initialize()
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Set pKeyValues = New Collection
        
        Erase pKeys
        Erase pItems
    #Else
        Set pDictionary = CreateObject("Scripting.Dictionary")
    #End If
End Sub

Private Sub Class_Terminate()
    #If Mac Or Not UseScriptingDictionaryIfAvailable Then
        Set pKeyValues = Nothing
    #Else
        Set pDictionary = Nothing
    #End If
End Sub

---

转载请注明来源，欢迎对文章中的引用来源进行考证，欢迎指出任何有错误或不够清晰的表达。可以在下面评论区评论，也可以邮件至 richffan@outlook.com