rsacryptoserviceprovider.cls

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

' Verifies the data using the signature.
'
' @param Buffer The data to be verified.
' @param hAlg The hash algorithm used to verify to the data. This is the same algorithm used to sign the data. Only SHA1 and MD5 are supported.
' @param Signature The signature used to ensure the data is valid.
' @return Returns True if the data has a valid signature, False otherwise.
' @remarks The hash algorithms can be specified either by the OID string, the hash name, or an actual instance of a hash
' object that implements either the <b>SHA1</b> or <b>MD5</b> interface.
' @see CryptoConfig
' @see SHA1
' @see MD5
' @see SHA1CryptoServiceProvider
' @see SHA1Manged
' @see MD5CryptoServiceProvider
'
Public Function VerifyData(ByRef Buffer() As Byte, ByRef hAlg As Variant, ByRef Signature() As Byte) As Boolean
    If cArray.IsNull(Buffer) Then _
        Throw Cor.NewArgumentNullException(Environment.GetResourceString(ArgumentNull_Array), "Buffer")
                  
    Dim HashObj As HashAlgorithm
    Set HashObj = GetHash(hAlg)
    
    VerifyData = VerifyHash(HashObj.ComputeHash(Buffer), GetOID(HashObj), Signature)
End Function

''
' Verifies the hash using the signature.
'
' @param RgbHash The hash to be verified.
' @param Str The type of hash value being signed.
' @param Signature The signature for the hash data.
' @return Returns True if the signature is correct, False otherwise.
' @remarks Only SHA1 and MD5 hashes are supported.
' <p>The <i>Str</i> parameter can be "SHA", "SHA1", "MD5", or the OID.
' @see CryptoConfig
'
Public Function VerifyHash(ByRef RgbHash() As Byte, ByVal Str As String, ByRef Signature() As Byte) As Boolean
    If cArray.IsNull(Signature) Then _
        Throw Cor.NewArgumentNullException(Environment.GetResourceString(ArgumentNull_Array), "Signature")
    
    Dim Hash As Long
    Hash = SetHash(RgbHash, Str)

    ' We need to reverse the signature to deal with .NET's big-endian form.
    Dim RevSig() As Byte
    RevSig = ReverseByteCopy(Signature)
    
    VerifyHash = CBool(CryptVerifySignature(Hash, RevSig(0), cArray.GetLength(Signature), mKey, vbNullString, 0))
    Call CryptDestroyHash(Hash)
End Function

''
' This function determines if the value passed in is the same
' as the current object instance. Meaning, are the Value and
' this object the same object in memory.
'
' @param Value The value to test for equality.
'
Public Function Equals(ByRef Value As Variant) As Boolean
    Equals = Object.Equals(Me, Value)
End Function

''
' Returns a psuedo-unique number used to help identify this
' object in memory. The current method is to return the value
' obtained from ObjPtr. If a different method needs to be impelmented
' then change the method here in this function.
'
' An override might be necessary if the hashcode should be
' derived from a value contained within the class.
'
Public Function GetHashCode() As Long
    GetHashCode = ObjPtr(CUnk(Me))
End Function

''
' Returns a string representation of this object instance.
' The default method simply returns the application name
' and class name in which this class resides.
'
' A Person class may return the person's name instead.
'
Public Function ToString() As String
    ToString = Object.ToString(Me, App)
End Function



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Friend Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Friend Sub Init(ByVal KeySize As Long, ByVal Params As CspParameters)
    If KeySize > 0 Then mKeySize = KeySize
    
    If Not Params Is Nothing Then
        With Params
            mProviderName = .ProviderName
            mProviderType = .ProviderType
            mKeyContainerName = .KeyContainerName
            mKeyNumber = .KeyNumber
            mFlags = .Flags
        End With
        
        mPersistKeyInCsp = True
    End If
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Private Helpers
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub VerifyLoaded(Optional ByVal IncludeKey As Boolean = True)
    If mIsDisposed Then _
        Throw New ObjectDisposedException
        
    Call LoadProvider
    
    If IncludeKey Then
        Call GenerateKey
    End If
End Sub

''
' This attempts to acquire a new provider and create a new key container
' within the specified provider. If the container name doesn't exist, then
' a random name will be created. If the container itself already exists,
' then the existing container will be used instead of creating a new one.
Private Sub LoadProvider()
    If mProvider <> vbNullPtr Then Exit Sub
    
    Dim dwFlags As Long
    If mFlags And CspProviderFlags.UseMachineKeyStore Then dwFlags = CRYPT_MACHINE_KEYSET
    
    mProvider = CryptoAPI.AcquireContext(mKeyContainerName, mProviderName, mProviderType, dwFlags)
End Sub

Private Sub GenerateKey()
    If mKey <> vbNullPtr Then Exit Sub
    
    If mFlags And UseExistingKey Then
        ' Try to get an existing key.
        If CryptGetUserKey(mProvider, mKeyNumber, mKey) <> BOOL_FALSE Then Exit Sub
        
        ' Something went wrong. If it's something other than
        ' not finding the key, then it's bad, so fail.
        If Err.LastDllError <> NTE_NO_KEY Then _
            Throw Cor.NewCryptographicException(GetErrorMessage(Err.LastDllError))
            
        ' We didn't find an existing key, so continue and create a new one.
    End If
    
    Dim Flags As Long
    Flags = Helper.ShiftLeft(mKeySize, 16)  ' the key size is held in the upper 16-bits.
    
    ' We must specify to make the key archivable.
    If mFlags And UseArchivableKey Then Flags = Flags Or CRYPT_ARCHIVABLE
    
    ' We must specify to NOT create an exportable key.
    If (mFlags And UseNonExportableKey) = 0 Then Flags = Flags Or CRYPT_EXPORTABLE
    
    If Not CryptoAPI.SupportsAlgorithm(mProvider, IIf(mKeyNumber = AT_KEYEXCHANGE, CALG_RSA_KEYX, CALG_RSA_SIGN)) Then _
        Throw Cor.NewCryptographicException("The Cryptography Service Provider (CSP) does not support the specified algorithm.")
    
    ' Let'er rip! This can take a bit with large key sizes.
    If CryptGenKey(mProvider, mKeyNumber, Flags, mKey) = BOOL_FALSE Then _
        Throw Cor.NewCryptographicException(GetErrorMessage(Err.LastDllError))
End Sub

Private Sub DeleteKey()
    Call CryptoAPI.DestroyKey(mKey)
    mKey = vbNullPtr
End Sub

Private Function SetHash(ByRef RgbHash() As Byte, ByVal Str As String) As Long
    Call VerifyLoaded
    
    If cArray.IsNull(RgbHash) Then _
        Throw Cor.NewArgumentNullException(Environment.GetResourceString(ArgumentNull_Array), "RgbHash")
    
    Dim HashAlg As Long
    Dim HashLen As Long
    Select Case LCase$(Str)
        Case "1.3.14.3.2.26", "sha", "sha1":    HashAlg = CALG_SHA1: HashLen = 20
        Case "1.2.840.113549.2.5", "md5":       HashAlg = CALG_MD5: HashLen = 16
        Case Else
            Throw Cor.NewArgumentException("Only SHA1 and MD5 hash algorithms are supported.", "Str")
    End Select
    
    If cArray.GetLength(RgbHash) <> HashLen Then _
        Throw Cor.NewCryptographicException("Invalid hash length.")
    
    On Error GoTo errTrap
    
    Dim Hash As Long
    If CryptCreateHash(mProvider, HashAlg, 0, 0, Hash) = BOOL_FALSE Then _
        Throw Cor.NewCryptographicException(GetErrorMessage(Err.LastDllError))

    If CryptSetHashParam(Hash, HP_HASHVAL, RgbHash(LBound(RgbHash)), 0) = 0 Then _
        Throw Cor.NewCryptographicException(GetErrorMessage(Err.LastDllError))

    SetHash = Hash
    Exit Function
    
errTrap:
    If Hash <> vbNullPtr Then Call CryptDestroyHash(Hash)
    
    Dim Ex As Exception
    If Catch(Ex) Then Throw Ex
End Function

Private Function GetOID(ByVal HashObj As HashAlgorithm) As String
    Dim OID As String
    If TypeOf HashObj Is SHA1 Then
        OID = CryptoConfig.MapNameToOID("SHA1")
    ElseIf TypeOf HashObj Is MD5 Then
        OID = CryptoConfig.MapNameToOID("MD5")
    End If
    
    GetOID = OID
End Function

Private Function GetHash(ByRef hAlg As Variant) As HashAlgorithm
    Dim HashObj As HashAlgorithm
    
    Select Case VarType(hAlg)
        Case vbString
            Select Case LCase$(hAlg)
                Case "1.3.14.3.2.26", "sha", "sha1": Set HashObj = New SHA1CryptoServiceProvider
                Case "1.2.840.113549.2.5", "md5":    Set HashObj = New MD5CryptoServiceProvider
                Case Else
                    Throw Cor.NewArgumentException("Only SHA1 and MD5 hash algorithms are supported.", "hAlg")
            End Select
            
        Case vbObject
            If hAlg Is Nothing Then _
                Throw Cor.NewArgumentNullException("Hash object cannot be Nothing.", "hAlg")
            
            If (TypeOf hAlg Is SHA1) Or (TypeOf hAlg Is MD5) Then
                Set HashObj = hAlg
            Else
                Throw Cor.NewArgumentException("Hash object must be SHA1 or MD5 compatible.", "hAlg")
            End If
            
        Case Else
            Throw Cor.NewArgumentException("Invalid hash algorithm specified.", "hAlg")
    End Select
    
    Set GetHash = HashObj
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   Class Events
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Class_Initialize()
    ReDim mLegalKeySizes(0)
    If CryptoAPI.HasHighEncryption Then
        Set mLegalKeySizes(0) = Cor.NewKeySizes(384, 16384, 8)
        mKeySize = 1024
    Else
        Set mLegalKeySizes(0) = Cor.NewKeySizes(384, 512, 8)
        mKeySize = 512
    End If
    
    mProviderType = PROV_RSA_FULL
    mKeyNumber = AT_KEYEXCHANGE
End Sub

Private Sub Class_Terminate()
    Call CryptoAPI.DestroyKey(mKey)
    Call CryptoAPI.ReleaseContext(mProvider, Not mPersistKeyInCsp)
End Sub



'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   AsymmetricAlgorithm Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub AsymmetricAlgorithm_Clear()
    Call Clear
End Sub

Private Function AsymmetricAlgorithm_Equals(Value As Variant) As Boolean
    AsymmetricAlgorithm_Equals = Equals(Value)
End Function

Private Sub AsymmetricAlgorithm_FromXmlString(ByVal XmlString As String)
    Call FromXmlString(XmlString)
End Sub

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

Private Property Get AsymmetricAlgorithm_KeyExchangeAlgorithm() As String
    AsymmetricAlgorithm_KeyExchangeAlgorithm = KeyExchangeAlgorithm
End Property

Private Property Let AsymmetricAlgorithm_KeySize(ByVal RHS As Long)
    KeySize = RHS
End Property

Private Property Get AsymmetricAlgorithm_KeySize() As Long
    AsymmetricAlgorithm_KeySize = KeySize
End Property

Private Property Get AsymmetricAlgorithm_LegalKeySizes() As KeySizes()
    AsymmetricAlgorithm_LegalKeySizes = LegalKeySizes
End Property

Private Property Get AsymmetricAlgorithm_SignatureAlgorithm() As String
    AsymmetricAlgorithm_SignatureAlgorithm = SignatureAlgorithm
End Property

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

Private Function AsymmetricAlgorithm_ToXmlString(ByVal IncludePrivateParameters As Boolean) As String
    AsymmetricAlgorithm_ToXmlString = ToXmlString(IncludePrivateParameters)
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   ICspAsymmetricAlgorithm Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Property Get ICspAsymmetricAlgorithm_CspKeyContainerInfo() As CspKeyContainerInfo
    Set ICspAsymmetricAlgorithm_CspKeyContainerInfo = CspKeyContainerInfo
End Property

Private Function ICspAsymmetricAlgorithm_ExportCspBlob(ByVal IncludePrivateParameters As Boolean) As Byte()
    ICspAsymmetricAlgorithm_ExportCspBlob = ExportCspBlob(IncludePrivateParameters)
End Function

Private Sub ICspAsymmetricAlgorithm_ImportCspBlob(RawData() As Byte)
    Call ImportCspBlob(RawData)
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   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


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   RSA Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub RSA_Clear()
    Call Clear
End Sub

Private Function RSA_DecryptValue(Rgb() As Byte) As Byte()
    RSA_DecryptValue = DecryptValue(Rgb)
End Function

Private Function RSA_EncryptValue(Rgb() As Byte) As Byte()
    RSA_EncryptValue = EncryptValue(Rgb)
End Function

Private Function RSA_Equals(Value As Variant) As Boolean
    RSA_Equals = Equals(Value)
End Function

Private Function RSA_ExportParameters(ByVal IncludePrivateParameters As Boolean) As RSAParameters
    Set RSA_ExportParameters = ExportParameters(IncludePrivateParameters)
End Function

Private Sub RSA_FromXmlString(ByVal XmlString As String)
    Call FromXmlString(XmlString)
End Sub

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

Private Sub RSA_ImportParameters(ByVal Parameters As RSAParameters)
    Call ImportParameters(Parameters)
End Sub

Private Property Get RSA_KeyExchangeAlgorithm() As String
    RSA_KeyExchangeAlgorithm = KeyExchangeAlgorithm
End Property

Private Property Let RSA_KeySize(ByVal RHS As Long)
    KeySize = RHS
End Property

Private Property Get RSA_KeySize() As Long
    RSA_KeySize = KeySize
End Property

Private Property Get RSA_LegalKeySizes() As KeySizes()
    RSA_LegalKeySizes = LegalKeySizes
End Property

Private Property Get RSA_SignatureAlgorithm() As String
    RSA_SignatureAlgorithm = SignatureAlgorithm
End Property

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

Private Function RSA_ToXmlString(ByVal IncludePrivateParameters As Boolean) As String
    RSA_ToXmlString = ToXmlString(IncludePrivateParameters)
End Function