ccrypto.cls

程序加密算法

        ' You may want to slow down a hacker trying multiple passwords to decrypt
        ' by brut force with a sleep command like this...
        'Sleep 1000
        
        ' Decrypt the text
        lResult = CryptDecrypt(lKey, 0, 1, 0, sText, lData)
        sText = Left(sText, lData)
        If lResult = 0 Then
            Err.Raise frezErrorDecryptingData, , ERROR_DECRYPTING_DATA
        End If
    End If
    
    EncryptDecrypt = sText
TIDY_UP:
    On Error Resume Next
        
    If lHash <> 0 Then
        lResult = CryptDestroyHash(lHash)
    End If
    If lKey <> 0 Then
        lResult = CryptDestroyKey(lKey)
    End If
    Err.Clear
    
    If lErr <> 0 Then
        Err.Raise lErr, "FrezCrypo.CCrypto.EncryptDecrypt", sErr
    End If
Exit Function
ERROR_HANDLER:
    lErr = Err.Number
    sErr = Err.Description
    GoTo TIDY_UP
End Function

'*******************************************************************************
' Encrypt (FUNCTION)
'
' PARAMETERS:
' (In) - sTextToEncrypt   - String                   - Text to encrypt
' (In) - sPrivateKey      - String                   - String to use for key
' (In) - bReturnTextInHex - Boolean                  - Whether to return the
'                                                      encypted text as hex
' (In) - enEncryptionType - frezCryptoEncryptionType - Block or stream encryption
'
' RETURN VALUE:
' String - The encrypted text
'
' DESCRIPTION:
' User calls this method to encrypt the string specified by sTextToEncrypt. The
' user passes a string to generate the private key with that will be used to
' encrypt the string. The user can also specify whether the string is to be
' returned in hex, it will be twice the size, but human readable. Finally, the
' user can specify which encryption method to use Block (more secure) or
' stream.
'*******************************************************************************
Public Function Encrypt(ByVal sTextToEncrypt As String, _
                        ByVal sPrivateKey As String, _
                        Optional ByVal bReturnTextInHex As Boolean _
                                                        = False, _
                        Optional ByVal enEncryptionType As frezCryptoEncryptionType _
                                                        = frezBlockEncryption) As String
    Dim sEncryptedText As String
    
    If enEncryptionType <> frezBlockEncryption And enEncryptionType <> frezStreamEncryption Then
        Err.Raise frezErrorBadEncryptionType, "FrezCrypo.CCrypto.Encrypt", ERROR_BAD_ENCRYPTION_TYPE
    End If
    
    If sTextToEncrypt = "" Or sPrivateKey = "" Then
        Err.Raise frezErrorMissingParameter, "FrezCrypo.CCrypto.Encrypt", ERROR_MISSING_PARAMETER
    End If
        
    sEncryptedText = EncryptDecrypt(sTextToEncrypt, sPrivateKey, True, enEncryptionType)
    
    If bReturnTextInHex Then
        Encrypt = ConvertStringToHex(sEncryptedText)
    Else
        Encrypt = sEncryptedText
    End If
End Function

'*******************************************************************************
' Decrypt (FUNCTION)
'
' PARAMETERS:
' (In) - sTextToDecrypt     - String                   - Text to decrypt
' (In) - sPrivateKey        - String                   - String to use for key
' (In) - bTextSuppliedInHex - Boolean                  - Whether the text provided
'                                                        is in hex or not
' (In) - enEncryptionType   - frezCryptoEncryptionType - Block or stream encryption
'
' RETURN VALUE:
' String - The decrypted text
'
' DESCRIPTION:
' User calls this method to decrypt the string specified by sTextToDecrypt. The
' user passes a string to generate the private key with that will be used to
' decrypt the string. The user can also specify whether the string was supplied
' in hex, human readable. Finally, the user can specify which encryption method
' was used Block (more secure) or stream.
'*******************************************************************************
Public Function Decrypt(ByVal sTextToDecrypt As String, _
                        ByVal sPrivateKey As String, _
                        Optional ByVal bTextSuppliedInHex As Boolean _
                                                        = False, _
                        Optional ByVal enEncryptionType As frezCryptoEncryptionType _
                                                        = frezBlockEncryption) As String
                        
    If enEncryptionType <> frezBlockEncryption And enEncryptionType <> frezStreamEncryption Then
        ' Phil Fresle - 22-Feb-2000 21:51
        ' Changed source to show decrypt instead of encrypt
        Err.Raise frezErrorBadEncryptionType, "FrezCrypo.CCrypto.Decrypt", ERROR_BAD_ENCRYPTION_TYPE
    End If
    
    If sTextToDecrypt = "" Or sPrivateKey = "" Then
        Err.Raise frezErrorMissingParameter, "FrezCrypo.CCrypto.Decrypt", ERROR_MISSING_PARAMETER
    End If
    
    If bTextSuppliedInHex Then
        sTextToDecrypt = ConvertStringFromHex(sTextToDecrypt)
    End If
    
    Decrypt = EncryptDecrypt(sTextToDecrypt, sPrivateKey, False, enEncryptionType)
End Function

'*******************************************************************************
' ConvertStringToHex (FUNCTION)
'
' PARAMETERS:
' (In) - sText - String - Text to be converted to hex
'
' RETURN VALUE:
' String - String now in hex
'
' DESCRIPTION:
' Takes a string, steps through it character by character converting it to
' the hex value of the ascii value of the character
'*******************************************************************************
Private Function ConvertStringToHex(ByVal sText As String) As String
    Dim lCount  As Long
    Dim sHex    As String
    Dim sResult As String
    
    For lCount = 1 To Len(sText)
        sHex = Hex(Asc(Mid(sText, lCount, 1)))
        If Len(sHex) = 1 Then
            sHex = "0" & sHex
        End If
        sResult = sResult & sHex
    Next
    
    ConvertStringToHex = sResult
End Function

'*******************************************************************************
' ConvertStringFromHex (FUNCTION)
'
' PARAMETERS:
' (In) - sText - String - Text to be converted back from hex
'
' RETURN VALUE:
' String - String now in clear
'
' DESCRIPTION:
' Takes a string, goes through it every two characters, takes the ascii hex value
' contained in the two characters and converts it to the actual character
'*******************************************************************************
Private Function ConvertStringFromHex(ByVal sText As String) As String
    Dim lCount  As Long
    Dim sChar   As String
    Dim sResult As String
    Dim lLength As Long
    
    lLength = Len(sText)
    If lLength Mod 2 <> 0 Then
        Err.Raise frezErrorInvalidHexString, _
                    "FrezCrypo.CCrypto.ConvertStringFromHex", _
                    ERROR_INVALID_HEX_STRING
    End If
        
    For lCount = 1 To lLength
        sChar = Mid(sText, lCount, 1)
        If sChar < "0" Or sChar > "9" Then
            If sChar < "A" Or sChar > "F" Then
                Err.Raise frezErrorInvalidHexString, _
                            "FrezCrypo.CCrypto.ConvertStringFromHex", _
                            ERROR_INVALID_HEX_STRING
            End If
        End If
    Next
    
    For lCount = 1 To lLength Step 2
        sResult = sResult & Chr("&H" & Mid(sText, lCount, 2))
    Next
    
    ConvertStringFromHex = sResult
End Function

'*******************************************************************************
' Class_Initialize (SUB)
'
' PARAMETERS:
' None
'
' DESCRIPTION:
' When class is initialized get a handle to the context
'*******************************************************************************
Private Sub Class_Initialize()
    Dim lResult As Long
    
    ' Phil Fresle - 21-Feb-2000 17:47
    ' To fix NT4 it now passes CRYPT_VERIFYCONTEXT
    ' Aquire context to the microsoft default CSP
    lResult = CryptAcquireContext(m_lProvider, vbNullString, _
        CRYPTO_PROVIDER, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)
    
    If lResult = 0 Then
        Err.Raise frezErrorAquiringContext, _
                    "FrezCrypo.CCrypto.Class_Initialize", _
                    ERROR_AQUIRING_CONTEXT
    End If
End Sub

'*******************************************************************************
' Class_Terminate (SUB)
'
' PARAMETERS:
' None
'
' DESCRIPTION:
' When class terminates, tidy up the context
'*******************************************************************************
Private Sub Class_Terminate()
    Dim lResult As Long
    
    If m_lProvider <> 0 Then
        lResult = CryptReleaseContext(m_lProvider, 0)
    End If
End Sub