clscompress.cls

此为水费收费管理系统

    Dim x As Long
    Dim y As Long
    Dim z As Long
    'reset the SALT value
    strSALT = ""
    'Open the source file and read the content into a arrByteArray to pass onto encryption
    intNextFreeFile = FreeFile
    Open SourceFile For Binary As #intNextFreeFile
    ReDim arrByteArray(0 To LOF(intNextFreeFile) - 1)
    Get #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
    'Encrypt the arrByteArray
    EncryptByteArray arrByteArray(), Password
    '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 encrypted data in the destination file
    intNextFreeFile = FreeFile
    'first tack on strSALT 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(strSALT) + 1))
    For x = z To z + Len(strSALT) - 1
        arrByteArray(x) = Asc(Mid(strSALT, y, 1))
        y = y + 1
    Next x
    arrByteArray(UBound(arrByteArray)) = Len(strSALT) 'length of salt is last character
    Open DestFile For Binary As #intNextFreeFile
    Put #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
End Sub

Public Sub DecryptFile(ByVal SourceFile As String, ByVal DestFile As String, ByVal Password As String)
    'single key file decryption
    Dim intNextFreeFile As Integer
    Dim arrByteArray() As Byte
    Dim x As Long
    Dim y As Long
    'reset the SALT value
    strSALT = ""
    'Open the source file and read the content into arrByteArray to decrypt
    intNextFreeFile = FreeFile
    Open SourceFile For Binary As #intNextFreeFile
    ReDim arrByteArray(0 To LOF(intNextFreeFile) - 1)
    Get #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
    'extract the SALT
    '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.
    y = arrByteArray(UBound(arrByteArray))
    For x = UBound(arrByteArray) - y To UBound(arrByteArray) - 1
        strSALT = strSALT & Chr(arrByteArray(x))
    Next x
    ReDim Preserve arrByteArray(0 To (UBound(arrByteArray) - Len(strSALT) - 1))
    'Decrypt arrByteArray
    DecryptByteArray arrByteArray(), Password
    '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
    If FileLen(DestFile) > 0 Then Kill DestFile
    On Error GoTo 0
    'Store the decrypted data in the destination file
    intNextFreeFile = FreeFile
    Open DestFile For Binary As #intNextFreeFile
    Put #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
End Sub

Public Function EncryptString(ByVal Text As String, ByVal Password As String) As String
    'single key string encryption
    EncryptString = EncryptDecrypt(Text, Password, True)
End Function

Public Function DecryptString(ByVal Text As String, ByVal Password As String) As String
    'single key string decryption
    DecryptString = EncryptDecrypt(Text, Password, False)
End Function

Public Function EncryptByteArray(ByRef arrByteArray() As Byte, ByVal Password As String)
    'single key byte array encryption
    Dim strInput As String
    Dim strOutput As String
    strInput = StrConv(arrByteArray(), vbUnicode) 'convert to string
    strOutput = EncryptDecrypt(strInput, Password, True) 'return the encrypted data
    arrByteArray() = StrConv(strOutput, vbFromUnicode) 'convert to byte array
End Function

Public Function DecryptByteArray(ByRef arrByteArray() As Byte, ByVal Password As String)
    'single key byte array encryption
    Dim strInput As String
    Dim strOutput As String
    strInput = StrConv(arrByteArray(), vbUnicode) 'convert to string
    strOutput = EncryptDecrypt(strInput, Password, False) 'return the encrypted data
    arrByteArray() = StrConv(strOutput, vbFromUnicode) 'convert to byte array
End Function

Public Sub Generate_KeyPair(Optional UseExchangeKeyPair As Boolean = True)
    'generate a new key pair, export it, and set the key handle so you can next call EncryptFile_KeyPair
    Dim lngParams As Long
    Dim lngReturnValue As Long
    Dim lngKeyLength As Long
    Dim strTemp As String
    lngKeyLength = lngTheKeyLength
    'display key length and CSP in use
    strTemp = "Using key length of: " & lngKeyLength / 65536 & " using this CSP: " & USE_THIS_CSP
    MsgBox strTemp
    lngParams = lngKeyLength Or CRYPT_EXPORTABLE Or CRYPT_NO_SALT   'set the key length, allow the keys to be exported, no salt
    If UseExchangeKeyPair Then 'set the type of key pair (Exchange key pair or Signature key pair)
        lngType = AT_KEYEXCHANGE
    Else
        lngType = AT_SIGNATURE
    End If
    'release old key pair handle
    If hKeyPair <> 0 Then CryptDestroyKey hKeyPair
    'generate the key pair
    lngReturnValue = CryptGenKey(hCryptProv, lngType, lngParams, hKeyPair)
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not generate public/private key pair"
End Sub

Public Sub Export_KeyPair(ByVal PrivateKeyPassword As String)
    'export the keys so they are available via the properties ValuePublicKey and ValuePublicPrivateKey
    Dim lngReturnValue As Long
    Dim lngLength As Long
    'Export the public key to strPublicBlob (ValuePublicKey property). This key is not encrypted
    lngReturnValue = CryptExportKey(hKeyPair, 0, PUBLICKEYBLOB, 0, vbNull, _
        lngLength) 'get the size of the buffer needed for the BLOB
    strPublicBlob = String(lngLength, vbNullChar)
    lngReturnValue = CryptExportKey(hKeyPair, 0, PUBLICKEYBLOB, 0, strPublicBlob, _
        lngLength) 'get the BLOB
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not export the public key blob"
    'Export the private key to strPublicPrivateBlob (ValuePublicPrivateKey property)
    'This key is encrypted with a password first get a handle to a session key derived from a password
    SessionKeyFromPassword (PrivateKeyPassword)
    lngReturnValue = CryptExportKey(hKeyPair, hSessionKey, PRIVATEKEYBLOB, 0, vbNull, _
        lngLength) 'get the size of the buffer needed for the BLOB
    strPublicPrivateBlob = String(lngLength, vbNullChar)
    lngReturnValue = CryptExportKey(hKeyPair, hSessionKey, PRIVATEKEYBLOB, 0, _
        strPublicPrivateBlob, lngLength) 'get the BLOB
    If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
        "DLL error code shown above. Could not export the private key blob"
End Sub

Public Sub Import_KeyPair(Optional ByVal PrivateKeyPassword As String = vbNullString, _
    Optional ByVal UseExchangeKeyPair As Boolean = True)
    'import keys
    Dim lngReturnValue As Long
    Dim lngLength As Long
    Dim lngParams As Long
    'check to see if there are no keys available at all
    If strPublicPrivateBlob = vbNullString And strPublicBlob = vbNullString Then
        Err.Raise vbObjectError + 1, , "One of the ValueXXXKey properties must hold a valid key"
    End If
    'release old key pair handle
    If hKeyPair <> 0 Then CryptDestroyKey hKeyPair
    If UseExchangeKeyPair Then 'set the type of key pair (Exchange key pair or Signature key pair keys)
        lngType = AT_KEYEXCHANGE
    Else
        lngType = AT_SIGNATURE
    End If
    If strPublicPrivateBlob = vbNullString Then 'must be a Public key
        'import the key
        lngLength = Len(strPublicBlob)
        lngReturnValue = CryptImportKey(hCryptProv, strPublicBlob, lngLength, 0, 0, hKeyPair)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not import the Public key"
    Else
        'must be a PublicPrivate key
        'get a session key handle from the password to unlock the private key, which is encrypted
        SessionKeyFromPassword PrivateKeyPassword
        'import the key
        lngLength = Len(strPublicPrivateBlob)
        lngParams = CRYPT_EXPORTABLE Or CRYPT_NO_SALT
        lngReturnValue = CryptImportKey(hCryptProv, strPublicPrivateBlob, _
            lngLength, hSessionKey, lngParams, hKeyPair)
        If lngReturnValue = 0 Then Err.Raise Err.LastDllError, , _
            "DLL error code shown above. Could not import the PublicPrivate key.  " & _
            "Most likely an incorrect private key password was entered."
    End If
    'release session key handle
    If hSessionKey <> 0 Then CryptDestroyKey hSessionKey
End Sub

Public Sub EncryptFile_KeyPair(ByVal SourceFile As String, ByVal DestFile As String)
    'key pair file encryption
    Dim intNextFreeFile As Integer
    Dim arrByteArray() As Byte
    Dim x As Long
    Dim y As Long
    Dim z As Long
    'reset strSessionBlob
    strSessionBlob = ""
    'Open the source file and read the content into a arrByteArray to pass onto encryption
    intNextFreeFile = FreeFile
    Open SourceFile For Binary As #intNextFreeFile
    ReDim arrByteArray(0 To LOF(intNextFreeFile) - 1)
    Get #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
    'Encrypt the arrByteArray
    EncryptByteArray_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 encrypted data in the destination file first tack on strSessionBlob 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(strSessionBlob) + 1))
    For x = z To z + Len(strSessionBlob) - 1
        arrByteArray(x) = Asc(Mid(strSessionBlob, y, 1))
        y = y + 1
    Next x
    arrByteArray(UBound(arrByteArray)) = Len(strSessionBlob) 'length of blob is last character
    intNextFreeFile = FreeFile
    Open DestFile For Binary As #intNextFreeFile
    Put #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
End Sub

Public Function DecryptFile_KeyPair(ByVal SourceFile As String, ByVal DestFile As String)
    'key pair file decryption
    Dim intNextFreeFile As Integer
    Dim arrByteArray() As Byte
    Dim x As Long
    Dim y As Long
    'reset the strSessionBlob value
    strSessionBlob = ""
    'Open the source file and read the content into arrByteArray to decrypt
    intNextFreeFile = FreeFile
    Open SourceFile For Binary As #intNextFreeFile
    ReDim arrByteArray(0 To LOF(intNextFreeFile) - 1)
    Get #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
    'extract strSessionBlob
    '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.
    y = arrByteArray(UBound(arrByteArray))
    For x = UBound(arrByteArray) - y To UBound(arrByteArray) - 1
        strSessionBlob = strSessionBlob & Chr(arrByteArray(x))
    Next x
    ReDim Preserve arrByteArray(0 To (UBound(arrByteArray) - Len(strSessionBlob) - 1))
    'Decrypt the arrByteArray
    DecryptByteArray_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
    If FileLen(DestFile) > 0 Then Kill DestFile
    On Error GoTo 0
    'Store the decrypted data in the destination file
    intNextFreeFile = FreeFile
    Open DestFile For Binary As #intNextFreeFile
    Put #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
End Function

Public Function EncryptString_KeyPair(ByVal Text As String) As String
    'key pair string encryption
    EncryptString_KeyPair = EncryptDecrypt_KeyPair(Text, True)
End Function

Public Function DecryptString_KeyPair(ByVal Text As String) As String
    'key pair string decryption
    DecryptString_KeyPair = EncryptDecrypt_KeyPair(Text, False)
End Function

Public Function EncryptByteArray_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, True) 'return the encrypted data
    arrByteArray() = StrConv(strOutput, vbFromUnicode) 'convert to byte array