clscompress.cls

此为水费收费管理系统

End Function

Public Function DecryptByteArray_KeyPair(ByRef arrByteArray() As Byte)
    'key pair byte array encryption
    Dim strInput As String
    Dim strOutput As String
    strInput = StrConv(arrByteArray(), vbUnicode) 'convert to string
    strOutput = EncryptDecrypt_KeyPair(strInput, False) 'return the encrypted data
    arrByteArray() = StrConv(strOutput, vbFromUnicode) 'convert to byte array
End Function

Public Sub SessionStart()
    'this could be placed at the beginning of EncryptDecrypt, but if you are doing
    'multiple encryptions/decryptions, calling this once speeds things up
    Dim lngReturnValue As Long
    'Get handle to CSP
    lngReturnValue = CryptAcquireContext(hCryptProv, KEY_CONTAINER, USE_THIS_CSP, _
        PROV_RSA_FULL, CRYPT_NEWKEYSET) 'try to make a new key container
    If lngReturnValue = 0 Then
        lngReturnValue = CryptAcquireContext(hCryptProv, KEY_CONTAINER, USE_THIS_CSP, _
            PROV_RSA_FULL, 0) 'try to get a handle to a key container that already exists, and if it fails...
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , "DLL error code shown " & _
            "above.  Error during CryptAcquireContext for a new key container." & vbCrLf & _
            "A container with this name probably already exists."
    End If
End Sub

Public Sub SessionEnd()
    'Release any session key handle
    If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
    'Release any key pair handle
    If hKeyPair <> 0 Then CryptDestroyKey hKeyPair
    'Release provider handle
    If hCryptProv <> 0 Then CryptReleaseContext hCryptProv, 0
End Sub

Private Function EncryptDecrypt(ByVal Text As String, Key As String, Encrypt As Boolean) As String
    'the code in this function encrypts/decrypts the data using a single key
    Dim lngLength As Long
    Dim lngSALTLen As Long
    Dim lngReturnValue As Long
    SessionKeyFromPassword Key 'get a session key derived from the password
    'Set a random SALT.  Always 11 bytes long for the Base CSP, but this code gets the allowed length the correct way
    'since other CSPs can have longer lengths.  This shows you how.
    If Encrypt Then 'only get a new SALT during encryption
        lngReturnValue = CryptGetKeyParam(hSessionKey, KP_SALT, vbNull, lngSALTLen, 0) 'get the allowed length of the SALT
        'lngReturnValue above is always 0 when you pass in the vbNull parameter, so no reason to check for an error.
        strSALT = String(lngSALTLen + 1, vbNullChar) 'initialize the buffer
        lngReturnValue = CryptGenRandom(hCryptProv, lngSALTLen, strSALT) 'generate a random SALT.
        'To set your own you can use the following line instead of the previous line:
        'strSALT = "12345678901" & vbnullchar
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not generate a random SALT"
        'the SALT is now available via the ValueSALT property
    End If
    lngReturnValue = CryptSetKeyParam(hSessionKey, KP_SALT, strSALT, 0)
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not set the SALT."
    'Note that the same SALT must be used during encryption and decryption.
    'A SALT causes the encrypted output to be different even when the input plaintext and password are the same,
    'thus the SALT should be different every single time you encrypt a file or string.
    'The SALT should be sent as plaintext along with the encrypted file.  This does not make the
    'encryption any weaker.
    
    'uncomment this code if you want to verify the SALT value set above
    'strSALT = String(12, vbNullChar) 'clear the string
    'lngSALTLen = 0 'clear the variable
    'lngReturnValue = CryptGetKeyParam(hSessionKey, KP_SALT, vbNull, lngSALTLen, 0) 'get the length of the SALT
    'lngReturnValue = CryptGetKeyParam(hSessionKey, KP_SALT, strSALT, lngSALTLen, 0) 'get the SALT
    'If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , "DLL error code shown above. Could not get the SALT."
    'MsgBox "get " & lngSALTLen & " " & strSALT
    
    'Encrypt or decrypt depending on the Encrypt parameter
    lngLength = Len(Text)
    If Encrypt Then
        lngReturnValue = CryptEncrypt(hSessionKey, 0, 1, 0, Text, lngLength, lngLength)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Error during CryptEncrypt."
    Else
        lngReturnValue = CryptDecrypt(hSessionKey, 0, 1, 0, Text, lngLength)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Error during CryptDecrypt."
    End If
    'return the encrypted/decrypted data and chop off extra padding
    EncryptDecrypt = Left$(Text, lngLength)
    'Destroy the session key
    If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
End Function
Private Function EncryptDecrypt_KeyPair(ByVal Text As String, Encrypt As Boolean) As String
    'the code in this function encrypts/decrypts the data using a single key
    Dim lngLength As Long
    Dim lngReturnValue As Long
    If Encrypt Then 'get the public key and encrypt
        'first release old session handle
        If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
        'get a random session key
        lngReturnValue = CryptGenKey(hCryptProv, CALG_RC4, CRYPT_EXPORTABLE, hSessionKey)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not create session key for use in key pair encryption"
        'first release old key pair handle
        If hKeyPair <> 0 Then CryptDestroyKey hKeyPair
        'get a handle to the key pair
        lngReturnValue = CryptGetUserKey(hCryptProv, lngType, hKeyPair)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not obtain public key for use in key pair encryption"
        'export and encrypt the session key
        lngReturnValue = CryptExportKey(hSessionKey, hKeyPair, SIMPLEBLOB, 0, vbNull, lngLength) 'get the size of the buffer needed for the BLOB
        strSessionBlob = String(lngLength, vbNullChar)
        lngReturnValue = CryptExportKey(hSessionKey, hKeyPair, SIMPLEBLOB, 0, strSessionBlob, lngLength) 'get the BLOB
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not export the session key during key pair encryption"
        'encrypt the data
        lngLength = Len(Text)
        lngReturnValue = CryptEncrypt(hSessionKey, 0, 1, 0, Text, lngLength, lngLength)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Error during key pair CryptEncrypt encryption."
    Else
        'get the private key and decrypt. first release old session handle
        If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
        'import the session key
        lngLength = Len(strSessionBlob)
        lngReturnValue = CryptImportKey(hCryptProv, strSessionBlob, lngLength, hKeyPair, 0, hSessionKey)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not import the session key " & _
            "during key pair decryption.  Most likely an incorrect private " & _
            "key was used, thus it could not decrypt the session key."
        'first release old key pair handle
        If hKeyPair <> 0 Then CryptDestroyKey hKeyPair
        'get a handle to the key pair
        lngReturnValue = CryptGetUserKey(hCryptProv, lngType, hKeyPair)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not obtain private key for use in key pair decryption"
        'decrypt
        lngLength = Len(Text)
        lngReturnValue = CryptDecrypt(hSessionKey, 0, 1, 0, Text, lngLength)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Error during key pair CryptDecrypt decryption."
    End If
    'return the encrypted/decrypted data and chop off extra padding
    EncryptDecrypt_KeyPair = Left$(Text, lngLength)
    'Destroy the session key
    If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
End Function

Private Sub SessionKeyFromPassword(ByVal Key As String)
    'This sub takes a string key as input and sets the module-level
    'hSessionKey variable to a new session key handle.
    'This sub is used by EncryptDecrypt, Export_KeyPair and Import_KeyPair.
    Dim lngParams As Long
    Dim lngReturnValue As Long
    Dim strHash As String
    Dim lngHashLen As Long
    Dim hHash As Long 'the handle to the hash object
    'Create a hash object to calculate a session key from the Password (instead of encrypting
    'with the actual key)
    lngReturnValue = CryptCreateHash(hCryptProv, CALG_SHA, 0, 0, hHash)
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not create a Hash Object (CryptCreateHash API)"
    'can use CALG_MD5 to get a 128-bit hash.  CALG_SHA returns a 160-bit hash (more secure).
    'Hash the Password
    lngReturnValue = CryptHashData(hHash, Key, Len(Key), 0)
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not calculate a Hash Value (CryptHashData API)"
    'A hash is a 'fingerprint' of any string.
    'Hashes are extremely useful for determining whether a
    'transmission or file has been altered.  This code can use
    'one of two algorithms (see note above).  No matter what the
    'length of input data, the hash will be a fixed length and
    'will be unique for that string of data.  The same hash is produced for
    'the same input data every time.  This is useful here to
    'produce a fixed-length, unique password for any length password entered.
    
    'Get the actual hash value
    lngReturnValue = CryptGetHashParam(hHash, HP_HASHVAL, vbNull, lngHashLen, 0) 'get the hash length
    strHash = String(lngHashLen + 1, vbNullChar)
    lngReturnValue = CryptGetHashParam(hHash, HP_HASHVAL, strHash, lngHashLen, 0) 'get the hash value
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not lngReturnValuerieve the hash value"
    'Set certain values to add more flexibility and security.
    'Make the key exportable. (I don't export the key in this sample code)
    lngParams = CRYPT_EXPORTABLE 'use this when you generate your own SALT, which is recommended (see 8 lines below)
    'Make the key exportable and add a system-generated SALT.
    'use this line of code instead of the one above if you want the API to set the SALT...
    'but the SALT is the same every time so this shouldn't be used!
    'Note that I generate my own random SALT below.
    'lngParams = CRYPT_EXPORTABLE Or CRYPT_CREATE_SALT
    
    'release old session key handle if one exists
    If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
    'Derive a session key from the hash object
    lngReturnValue = CryptDeriveKey(hCryptProv, CALG_RC4, hHash, lngParams, hSessionKey)
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not create a session key (CryptDeriveKey API)"
    'Destroy the hash object
    If hHash <> 0 Then CryptDestroyHash hHash
End Sub

Private Function SignValidate_KeyPair(ByVal Text As String, Sign As Boolean) As String
    'Create a signature or verify a signature
    Dim hHash As Long
    Dim lngReturnValue As Long
    Dim lngSigLen As Long
    'reset the value
    SignValidate_KeyPair = vbNullString
    'Create a hash object to hash the input data
    lngReturnValue = CryptCreateHash(hCryptProv, CALG_SHA, 0, 0, hHash)
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not create a Hash Object (CryptCreateHash API)"
    'can use CALG_MD5 to get a 128-bit hash.  CALG_SHA returns a 160-bit hash (more secure).
    'Hash the data
    lngReturnValue = CryptHashData(hHash, Text, Len(Text), 0)
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not calculate a Hash Value (CryptHashData API)"
    If Sign Then 'sign it
        'Determine the size of signature
        lngReturnValue = CryptSignHash(hHash, AT_SIGNATURE, 0, 0, vbNull, lngSigLen)
        strSig = String(lngSigLen, vbNullChar) 'initialize the string
        'Sign hash object
        lngReturnValue = CryptSignHash(hHash, AT_SIGNATURE, 0, 0, strSig, lngSigLen)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not sign the hash"
        'return the signature and chop off extra padding
        strSig = Left$(strSig, lngSigLen)
        SignValidate_KeyPair = Text
        'the signature is now available via the ValueSignature property
    Else 'validate the signature
        'uses a signature placed into the ValueSignature property
        lngSigLen = Len(strSig)
        lngReturnValue = CryptVerifySignature(hHash, strSig, lngSigLen, hKeyPair, 0, 0)
        If lngReturnValue = 0 Then 'some error occurred
            If Err.LastDllError = NTE_BAD_SIGNATURE Then
                Err.Raise Err.LastDllError, , "DLL error code shown above. Bad signature.  " & _
                    "This might be because the data has changed, or the wrong public key " & _
                    "was used to check the signature."
            Else
                Err.Raise Err.LastDllError, , "DLL error code shown above. Could not verify the signature"
            End If
        End If 'some error occurred
        SignValidate_KeyPair = Text 'no error occurred
    End If
    'Destroy hash object.
    If hHash <> 0 Then CryptDestroyHash hHash
End Function

Public Sub SignFile_KeyPair(ByVal SourceFile As String, ByVal DestFile As String)
    'key pair file signing
    Dim intNextFreeFile As Integer
    Dim arrByteArray() As Byte
    Dim x As Long
    Dim y As Long
    Dim z As Long
    'reset strSig
    strSig = ""
    'Open the source file and read the content
    'into a arrByteArray to pass onto signature algorithm
    intNextFreeFile = FreeFile
    Open SourceFile For Binary As #intNextFreeFile
    ReDim arrByteArray(0 To LOF(intNextFreeFile) - 1)
    Get #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
    'sign the arrByteArray
    SignByteArray_KeyPair arrByteArray()
    'If the destination file already exists we need
    'to delete it since opening it for binary use
    'will preserve it if it already exists
    On Error Resume Next
    Kill DestFile
    On Error GoTo 0
    'Store the signed data in the destination file
    'first tack on strSig to arrByteArray
    'This is a kludge because while you can Put the the string
    'before arrByteArray, for some reason you can not then
    'Get the string when reading it back from the file, so I just
    'tacked it on to the array.
    z = UBound(arrByteArray) + 1
    y = 1
    ReDim Preserve arrByteArray(0 To (UBound(arrByteArray) + Len(strSig) + 1))
    For x = z To z + Len(strSig) - 1
        arrByteArray(x) = Asc(Mid(strSig, y, 1))
        y = y + 1
    Next x