registrykey.cls

这是一个在vb下实现的各种加密程序,可以实现一般的文本加密和文件加密,但是很多算法都是已经被人破解过的.

        Throw Cor.NewArgumentException("The value did not match the registry type specified by ValueKind.", "value")
    End If
End Sub

''
' Returns the value of a key within a SubKey.
'
' @param Name The name of the value to retrieve, or an empty string to retrieve the key default value.
' @param Default The value to be returned if the key name was not found.
' @param Options Additional options on how to handle how data is handled when reading from the key.
' @return The value found in the Registry, or Empty if the value does not exist.
' @remarks <b>RegistryKey</b> supports the return of 6 different key value types.<br>
' REG_DWORD (Integer numbers)<br>
' REG_QWORD (64-bit integer)<br>
' REG_BINARY (Byte arrays)<br>
' REG_SZ (Strings)<br>
' REG_MULTI_SZ (String arrays)<br>
' REG_EXPAND_SZ (String containing an environment variable)<br>
' The specific type will be created and returned based on the type in the registry.
' <p>If retrieving a REG_QWORD, a vbCurrency variable is returned to represent the
' 64-bit value. This means that the value will have the bias of being divided by
' 10000. To get the true 64-bit value, the vbCurrency value will need to be multiplied
' by 10000. The result may be an overflow.
'
Public Function GetValue(ByVal Name As String, Optional ByRef Default As Variant, Optional ByVal Options As RegistryValueOptions) As Variant
    Call VerifyHandle

    If Len(Name) > Registry.MaxValueNameLength Then _
        Throw Cor.NewArgumentException("Registry Value name must not exceed " & Registry.MaxValueNameLength & " characters.", "Name")

    Dim ValueType   As RegistryValueKind
    Dim ValueSize   As Long
    Dim Result      As Long
    Result = API.RegQueryValueEx(mHKey, Name, ValueType, 0, ValueSize)
    
    If Result = ERROR_FILE_NOT_FOUND Then
        If Not IsMissing(Default) Then Call VariantCopyInd(GetValue, Default)
        Exit Function
    ElseIf Result <> ERROR_SUCCESS Then
        IOError Result
    End If
    
    Select Case ValueType
        Case StringKind
            Dim sz As String
            sz = String$(ValueSize, 0)
            Result = API.RegQueryValueExStr(mHKey, Name, ValueType, sz)
            If Result <> ERROR_SUCCESS Then IOError Result
            GetValue = cString.TrimEnd(sz, vbNullChar)
            Exit Function
            
        Case DWordKind
            Dim i As Long
            Result = API.RegQueryValueEx(mHKey, Name, ValueType, VarPtr(i), 4)
            If Result <> ERROR_SUCCESS Then IOError Result
            GetValue = i
            
        Case BinaryKind, REG_NONE
            Dim Bytes() As Byte
            If ValueSize > 0 Then
                ReDim Bytes(0 To ValueSize - 1)
                Result = API.RegQueryValueEx(mHKey, Name, ValueType, VarPtr(Bytes(0)), ValueSize)
                If Result <> ERROR_SUCCESS Then IOError Result
            Else
                Bytes = Cor.NewBytes
            End If
            
            GetValue = Bytes
            Exit Function
            
        Case MultiStringKind
            Dim MultiSZ As String
            MultiSZ = String$(ValueSize, 0)
            Result = API.RegQueryValueExStr(mHKey, Name, ValueType, MultiSZ)
            If Result <> ERROR_SUCCESS Then IOError Result
            GetValue = Split(cString.TrimEnd(MultiSZ, vbNullChar), vbNullChar)
            Exit Function
            
        Case ExpandStringKind
            Dim ExpSZ As String
            ExpSZ = String$(ValueSize, 0)
            Result = API.RegQueryValueExStr(mHKey, Name, ValueType, ExpSZ)
            If Result <> ERROR_SUCCESS Then IOError Result
            ExpSZ = cString.TrimEnd(ExpSZ, vbNullChar)
            
            If Options <> DoNotExpandEnvironmentVariables Then
                ExpSZ = Environment.ExpandEnvironmentVariables(ExpSZ)
            End If
            
            GetValue = ExpSZ
            Exit Function
            
        Case QWordKind
            Dim c As Currency
            Result = API.RegQueryValueEx(mHKey, Name, ValueType, VarPtr(c), 8)
            If Result <> ERROR_SUCCESS Then IOError Result
            GetValue = c
            
        Case Else
            Throw Cor.NewArgumentException("Unsupported Registry type.")
    End Select
End Function

''
' Deletes the value from the registry.
'
' @param Name The name of the value to be deleted, or an empty string to delete the default value for the key.
' @param ThrowOnMissingValue Whether to throw an exception if the value was not found.
'
Public Sub DeleteValue(ByVal Name As String, Optional ByVal ThrowOnMissingValue As Boolean = True)
    Call VerifyWritable
    Call VerifyHandle
    
    Dim Result As Long
    Result = API.RegDeleteValue(mHKey, Name)
    If (Result = ERROR_FILE_NOT_FOUND) And ThrowOnMissingValue Then _
        Throw Cor.NewArgumentException("Value was not found.", "Name")
End Sub

''
' Returns the number of SubKeys within the current key.
'
' @return The number of SubKeys.
'
Public Property Get SubKeyCount() As Long
    Call VerifyHandle
    
    Dim Result As Long
    Result = API.RegQueryInfoKey(mHKey, vbNullString, 0, 0, VarPtr(SubKeyCount), 0, 0, 0, 0, 0, 0, 0)
    If Result <> ERROR_SUCCESS Then IOError Result, "RegistryKey"
End Property

''
' Returns the number of values within the current key.
'
' @remarks The number of values.
'
Public Property Get ValueCount() As Long
    Call VerifyHandle
    
    Dim Result As Long
    Result = API.RegQueryInfoKey(mHKey, vbNullString, 0, 0, 0, 0, 0, VarPtr(ValueCount), 0, 0, 0, 0)
    If Result <> ERROR_SUCCESS Then IOError Result, "RegistryKey"
End Property

''
' Returns the type of value stored in the registry.
'
' @param Name The name of the value to get the type of.
' @return The type of value in the registry.
'
Public Function GetValueKind(ByVal Name As String) As RegistryValueKind
    Call VerifyHandle
    
    Dim Result As Long
    Result = API.RegQueryValueEx(mHKey, Name, GetValueKind, 0, 0)
    If Result <> ERROR_SUCCESS Then IOError Result, "GetValueKind"
End Function

''
' Returns the last time the subkey was written to.
'
' @return A cDateTime object.
' @remarks This method returns cDateTime.MinValue on Windows 95,98 and ME.
'
Public Function GetLastWriteTime() As cDateTime
    Call VerifyHandle
    
    If Environment.IsNT Then
        Dim Result  As Long
        Dim Time    As Currency
        
        Result = API.RegQueryInfoKey(mHKey, vbNullString, 0, 0, 0, 0, 0, 0, 0, 0, 0, VarPtr(Time))
        If Result <> ERROR_SUCCESS Then IOError Result, "RegistryKey"
        
        Set GetLastWriteTime = cDateTime.FromFileTime(Time)
    Else
        Set GetLastWriteTime = cDateTime.MinValue
    End If
End Function

''
' Returns an enumerator to enumerate the name/value pairs.
'
' @param EnumType A flag indicating which type of values to be enumerated in the key.
' @param Options Additional options on how to handle registry values.
' @return An IEnumerator object.
'
Public Function GetEnumerator(Optional ByVal EnumType As IDictionaryEnumType = detEntries, Optional ByVal Options As RegistryValueOptions) As Object
    Call VerifyHandle
    
    Dim Ret As New RegistryKeyEnumerator
    Call Ret.Init(Me, EnumType, Options)
    Set GetEnumerator = Ret
End Function

''
' Returns a For..Each compatible enumerator.
'
' @return A For..Each compatible enumerator.
'
Public Function NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    Set NewEnum = CreateEnumerator(GetEnumerator)
End Function

''
' Returns a string representation of this object instance.
'
' @return String representing this instance.
Public Function ToString() As String
    ToString = Object.ToString(Me, App)
End Function

''
' Returns a boolean indicating if the value and this object
' instance are the same instance.
'
' @param value The value to compare equalit to.
' @return Boolean indicating equality.
Public Function Equals(ByRef Value As Variant) As Boolean
    Equals = Object.Equals(Me, Value)
End Function

''
' Returns a pseudo-unique number identifying this instance.
'
' @return Pseudo-unique number identifying this instance.
Public Function GetHashCode() As Long
    GetHashCode = ObjPtr(CUnk(Me))
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Friend Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Friend Sub Init(ByVal Key As Long, ByVal Name As String, ByVal Writable As Boolean)
    mHKey = Key
    mName = cString.Trim(Name, "\")
    mWritable = Writable
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Private Helpers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub VerifyKey(ByRef Path As String)
    Dim Keys() As String
    Keys = Split(Path, "\")
    
    Dim i As Long
    For i = 0 To UBound(Keys)
        If Len(Keys(i)) > MAX_KEY_LENGTH Then
            Throw Cor.NewArgumentException("Key names cannot exceed 255 characters.")
        End If
    Next i
End Sub

Private Function IsSystemKey() As Boolean
    If mHKey < &H80000006 Then Exit Function
    If mHKey > &H80000000 Then Exit Function
    IsSystemKey = True
End Function

Private Sub VerifyHandle()
    If mHKey = vbNullPtr Then Throw Cor.NewObjectDisposedException("RegistryKey", "The Registry Key is closed.")
    If mHKey = HKEY_DYN_DATA Then
        If Environment.IsNT Then IOError ERROR_INVALID_HANDLE
    End If
End Sub

Private Sub VerifyWritable()
    If Not mWritable Then Throw Cor.NewUnauthorizedAccessException("The Registry Key is not writable.")
End Sub

Private Function SetValueSZ(ByRef Name As String, ByRef Value As Variant) As Long
    SetValueSZ = API.RegSetValueExStr(mHKey, Name, REG_SZ, Value & vbNullChar)
End Function

Private Function SetValueMultiSZ(ByRef Name As String, ByRef Value As Variant) As Long
    Dim s As String
    If cArray.IsNull(Value) Then
        s = vbNullChar
    ElseIf cArray.GetLength(Value) > 0 Then
        s = Join(Value, vbNullChar) & (vbNullChar & vbNullChar)
    Else
        s = vbNullChar
    End If
    
    SetValueMultiSZ = API.RegSetValueExStr(mHKey, Name, REG_MULTI_SZ, s)
End Function

Private Function SetValueExpandSZ(ByRef Name As String, ByRef Value As Variant) As Long
    SetValueExpandSZ = API.RegSetValueExStr(mHKey, Name, REG_EXPAND_SZ, Value & vbNullChar)
End Function

Private Function SetValueDWord(ByRef Name As String, ByVal Value As Long) As Long
    SetValueDWord = API.RegSetValueEx(mHKey, Name, REG_DWORD, VarPtr(Value), 4)
End Function

Private Function SetValueBinary(ByRef Name As String, ByRef Value As Variant) As Long
    Dim lpData  As Long
    Dim Size    As Long
    
    If Not cArray.IsNull(Value) Then
        Size = cArray.GetLength(Value)
        If Size > 0 Then lpData = MemLong(GetArrayPointer(Value) + PVDATA_OFFSET)
    End If
    
    SetValueBinary = API.RegSetValueEx(mHKey, Name, REG_BINARY, lpData, Size)
End Function

Private Function SetValueQWord(ByRef Name As String, ByVal Value As Currency) As Long
    SetValueQWord = API.RegSetValueEx(mHKey, Name, REG_QWORD, VarPtr(Value), 8)
End Function

Private Function SetValueObject(ByRef Name As String, ByVal Value As IObject) As Long
    SetValueObject = SetValueSZ(Name, Value.ToString)
End Function

Private Function SetValueDirect(ByRef Name As String, ByRef Value As Variant)
    Dim Result As Long
    
    Select Case VarType(Value)
        Case vbLong, vbInteger, vbByte:     Result = SetValueDWord(Name, Value)
        Case vbStringArray, vbVariantArray: Result = SetValueMultiSZ(Name, Value)
        Case vbByteArray:                   Result = SetValueBinary(Name, Value)
        Case vbCurrency:                    Result = SetValueQWord(Name, Value)
        Case vbObject:                      Result = SetValueObject(Name, Value)
        Case Else:                          Result = SetValueSZ(Name, Value)
    End Select
    
    SetValueDirect = Result
End Function

Private Function SetValueWithConvert(ByRef Name As String, ByRef Value As Variant, ByVal ValueKind As RegistryValueKind) As Long
    Dim Result As Long
    
    Select Case ValueKind
        Case DWordKind:         Result = SetValueDWord(Name, Value)
        Case BinaryKind:        Result = SetValueBinary(Name, Value)
        Case MultiStringKind:   Result = SetValueMultiSZ(Name, Value)
        Case ExpandStringKind:  Result = SetValueExpandSZ(Name, Value)
        Case QWordKind
            ' We assume if an actual Currency datatype value was passed in
            ' then that value was the expected 64-bit value. If a different
            ' datatype (eg. vbLong) was passed in, then we assume that the
            ' 64-bits need to be lined up. A vbLong of 1 does not equal
            ' a vbCurrency of 1 in a 64-bit representation, so we need to
            ' divide the vbLong value by 10000 to have correct bit alignment.
            If VarType(Value) = vbCurrency Then
                Result = SetValueQWord(Name, Value)
            Else
                Result = SetValueQWord(Name, 0.0001@ * CCur(Value))
            End If
            
        Case Else
            If IsObject(Value) Then
                Result = SetValueObject(Name, Value)
            Else
                Result = SetValueSZ(Name, Value)
            End If
    End Select
    
    SetValueWithConvert = Result
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Class Events
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Terminate()
    Call CloseKey
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   IEnumerable Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function IEnumerable_GetEnumerator() As IEnumerator
    Set IEnumerable_GetEnumerator = GetEnumerator
End Function

Private Function IEnumerable_NewEnum() As stdole.IUnknown
    Set IEnumerable_NewEnum = NewEnum
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   IObject Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function IObject_Equals(Value As Variant) As Boolean
    IObject_Equals = Equals(Value)
End Function

Private Function IObject_GetHashcode() As Long
    IObject_GetHashcode = GetHashCode
End Function

Private Function IObject_ToString() As String
    IObject_ToString = ToString
End Function