dsacryptoserviceprovider.cls

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

'
Public Function CreateSignature(ByRef RgbHash() As Byte) As Byte()
    CreateSignature = SignHash(RgbHash, "sha1")
End Function

''
' Verifies the signature for the hash value.
'
' @param RgbHash The hash value to verify the signature of.
' @param RgbSignature The signature to be verified.
' @return Returns True if the signature if valid, False otherwise.
' @remarks Only SHA1 hash values are supported.
'
Public Function VerifySignature(ByRef RgbHash() As Byte, ByRef RgbSignature() As Byte) As Boolean
    VerifySignature = VerifyHash(RgbHash, "sha1", RgbSignature)
End Function

''
' Returns a boolean indicating if the value and this object
' instance are the same instance.
'
' @param value The value to test equality on.
' @return Boolean indicating equality.
' @see IObject
'
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 Flags As Long
    If mFlags And CspProviderFlags.UseMachineKeyStore Then Flags = CRYPT_MACHINE_KEYSET
    
    mProvider = CryptoAPI.AcquireDSAContext(mKeyContainerName, mProviderName, mProviderType, Flags)
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, CALG_DSS_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()
    If mKey <> vbNullPtr Then
        Call CryptDestroyKey(mKey)
        mKey = vbNullPtr
    End If
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")
    
    Select Case LCase$(Str)
        Case "1.3.14.3.2.26", "sha", "sha1"
        Case Else
            Throw Cor.NewArgumentException("Hash OID not supported", "Str")
    End Select
    
    If cArray.GetLength(RgbHash) <> 20 Then _
        Throw Cor.NewCryptographicException("Invalid hash length.")
    
    On Error GoTo errTrap
    
    Dim Hash As Long
    If CryptCreateHash(mProvider, CALG_SHA1, 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)
    
    Throw
End Function

Private Function GetOID(ByVal HashObj As HashAlgorithm) As String
    Dim OID As String
    If TypeOf HashObj Is SHA1 Then
        OID = "1.3.14.3.2.26"
    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 Else
                    Throw Cor.NewArgumentException("Only SHA1 hash algorithm is 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 Then
                Set HashObj = hAlg
            Else
                Throw Cor.NewArgumentException("Hash object must be SHA1 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)
    Set mLegalKeySizes(0) = Cor.NewKeySizes(512, 1024, 64)
    
    mProviderType = PROV_DSS_DH
    mKeyNumber = AT_SIGNATURE
End Sub

Private Sub Class_Terminate()
    Call Clear
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


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'   DSA Interface
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub DSA_Clear()
    Call Clear
End Sub

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

Private Function DSA_ExportParameters(ByVal IncludePrivateParameters As Boolean) As DSAParameters
    Set DSA_ExportParameters = ExportParameters(IncludePrivateParameters)
End Function

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

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

Private Sub DSA_ImportParameters(ByVal Parameters As DSAParameters)
    Call ImportParameters(Parameters)
End Sub

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

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

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

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

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

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

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

Private Function DSA_CreateSignature(RgbHash() As Byte) As Byte()
    DSA_CreateSignature = CreateSignature(RgbHash)
End Function

Private Function DSA_VerifySignature(RgbHash() As Byte, RgbSignature() As Byte) As Boolean
    DSA_VerifySignature = VerifySignature(RgbHash, RgbSignature)
End Function