clscompress.cls

此为水费收费管理系统

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClsCompress"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias _
    "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As _
    String, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal _
    dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv _
    As Long, ByVal Algid As Long, ByVal hSessionKey As Long, ByVal dwFlags _
    As Long, ByRef phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As _
    Long, ByVal pbData As String, ByVal dwDataLen As Long, ByVal dwFlags As _
    Long) As Long
Private Declare Function CryptDeriveKey Lib "advapi32.dll" (ByVal hProv As _
    Long, ByVal Algid As Long, ByVal hBaseData As Long, ByVal dwFlags As _
    Long, ByRef hSessionKey As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash _
    As Long) As Long
Private Declare Function CryptEncrypt Lib "advapi32.dll" (ByVal hSessionKey _
    As Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, _
    ByVal pbData As String, ByRef pdwDataLen As Long, ByVal dwBufLen As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" (ByVal hSessionKey _
    As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As _
    Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDecrypt Lib "advapi32.dll" (ByVal hSessionKey As _
    Long, ByVal hHash As Long, ByVal Final As Long, ByVal dwFlags As Long, ByVal _
    pbData As String, ByRef pdwDataLen As Long) As Long
Private Declare Function CryptGetKeyParam Lib "advapi32.dll" (ByVal hSessionKey _
    As Long, ByVal dwParam As Long, ByVal pbData As String, ByRef pdwDataLen As _
    Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetKeyParam Lib "advapi32.dll" (ByVal hSessionKey _
    As Long, ByVal dwParam As Long, ByVal pbData As String, ByVal dwFlags As Long) As Long
Private Declare Function CryptGenRandom Lib "advapi32.dll" (ByVal hProv As Long, _
    ByVal dwLen As Long, ByVal pbBuffer As String) As Long
Private Declare Function CryptGenKey Lib "advapi32.dll" (ByVal hProv As Long, _
    ByVal Algid As Long, ByVal dwFlags As Long, ByRef hSessionKey As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As _
    Long, ByVal dwParam As Long, ByVal pbData As String, ByRef pdwDataLen As _
    Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32.dll" (ByVal hHash As _
    Long, ByVal dwParam As Long, ByVal pbData As String, ByVal dwFlags As Long) As Long
Private Declare Function CryptExportKey Lib "advapi32.dll" (ByVal hSessionKey _
    As Long, ByVal hExpKey As Long, ByVal dwBlobType As Long, ByVal dwFlags As _
    Long, ByVal pbData As String, ByRef pdwDataLen As Long) As Long
Private Declare Function CryptImportKey Lib "advapi32.dll" (ByVal hProv As Long, _
    ByVal pbData As String, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal _
    dwFlags As Long, ByRef phKey As Long) As Long
Private Declare Function CryptGetUserKey Lib "advapi32.dll" (ByVal hProv As Long, _
    ByVal dwKeySpec As Long, ByVal phUserKey As Long) As Long
Private Declare Function CryptSignHash Lib "advapi32.dll" Alias "CryptSignHashA" _
    (ByVal hHash As Long, ByVal dwKeySpec As Long, ByVal sDescription As String, _
    ByVal dwFlags As Long, ByVal pbSignature As String, pdwSigLen As Long) As Long
Private Declare Function CryptVerifySignature Lib "advapi32.dll" Alias _
    "CryptVerifySignatureA" (ByVal hHash As Long, ByVal pbSignature As String, _
    ByVal dwSigLen As Long, ByVal hPubKey As Long, ByVal sDescription As String, _
    ByVal dwFlags As Long) As Long
Private Declare Function CryptEnumProviders Lib "advapi32.dll" Alias _
    "CryptEnumProvidersA" (ByVal dwIndex As Long, ByVal pdwReserved As Long, _
    ByVal dwFlags As Long, ByVal pdwProvType As Long, ByVal pszProvName As _
    String, ByRef pcbProvName As Long) As Long

'用以下函数进行压缩和解压缩：需要动态链接库《zlib.dll》支持，
'    将链接库拷贝到系统安装目录...\system 中就可以啦！
'===============================================================================================================================================
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As _
        Any, hpvSource As Any, ByVal cbCopy As Long)
    Private Declare Function compress Lib "zlib.dll" (dest As Any, destLen As Any, _
        src As Any, ByVal srcLen As Long) As Long
    Private Declare Function compress2 Lib "zlib.dll" (dest As Any, destLen As Any, _
        src As Any, ByVal srcLen As Long, ByVal level As Long) As Long
    Private Declare Function uncompress Lib "zlib.dll" (dest As Any, destLen As Any, _
        src As Any, ByVal srcLen As Long) As Long
'===============================================================================================================================================

'以下常数用来进行加密（encryption）和解密（decryption）
'===============================================================================================================================================
    Private Const MS_DEF_PROV As String = "Microsoft Base Cryptographic Provider v1.0" & vbNullChar
    Private Const MS_ENHANCED_PROV As String = "Microsoft Enhanced Cryptographic Provider v1.0" & vbNullChar
    Private Const USE_THIS_CSP As String = MS_ENHANCED_PROV 'can set this to other providers.  See Microsoft's website for full listing
    Private Const KEY_CONTAINER As String = "CryptoAPIExample" & vbNullChar 'this is usually set to your program's name
    Private Const PROV_RSA_FULL As Long = 1
    Private Const CRYPT_NEWKEYSET As Long = 8
    Private Const CRYPT_DELETEKEYSET As Long = 16
    Private Const CRYPT_CREATE_SALT As Long = 4
    Private Const CRYPT_EXPORTABLE As Long = 1
    Private Const KP_SALT As Long = 2
    Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
    Private Const ALG_CLASS_HASH As Long = 32768
    Private Const ALG_TYPE_ANY As Long = 0
    Private Const ALG_TYPE_STREAM As Long = 2048
    Private Const ALG_SID_RC4 As Long = 1
    Private Const ALG_SID_MD5 As Long = 3
    Private Const ALG_SID_SHA As Long = 4
    Private Const CALG_MD5 As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_MD5)
    Private Const CALG_RC4 As Long = ((ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM) Or ALG_SID_RC4)
    Private Const CALG_SHA As Long = ((ALG_CLASS_HASH Or ALG_TYPE_ANY) Or ALG_SID_SHA)
    Private Const AT_KEYEXCHANGE As Long = 1
    Private Const AT_SIGNATURE As Long = 2
    Private Const HP_HASHVAL As Long = 2
    Private Const SIMPLEBLOB = 1
    Private Const PUBLICKEYBLOB As Long = 6
    Private Const PRIVATEKEYBLOB As Long = 7
    Private Const CRYPT_NO_SALT = 16
    Private Const NTE_BAD_SIGNATURE As Long = -2146893818
    Private Const KEY_LENGTH_512 = &H2000000 'upper half = "200" hex = 512 decimal
    Private Const KEY_LENGTH_1024 = &H4000000 'upper half = "400" hex = 1024 decimal
    Private Const KEY_LENGTH_2048 = &H8000000 'etc....
    Private Const KEY_LENGTH_4096 = &H10000000
    Private Const KEY_LENGTH_8192 = &H20000000
    Private Const KEY_LENGTH_16384 = &H40000000
'===============================================================================================================================================

'以下变量数用来进行加密（encryption）和解密（decryption）
'===============================================================================================================================================
    Dim hCryptProv As Long 'the handle to the CSP
    Dim strSALT As String 'the session key SALT
    Dim strHash As String 'the value of the Hash
    Dim hSessionKey As Long 'the handle to the current session key
    Dim hKeyPair As Long 'the handle to the current key pair
    Dim strPublicPrivateBlob As String 'the value of the private key in BLOB format.  Note that the public key is also put in here by the CryptoAPI
    Dim strPublicBlob As String 'the value of the public key in BLOB format.  This is what you can send to other people.
    Dim strSessionBlob As String 'the encrypted session key used during key pair encryption/decryption
    Dim lngType As Long 'type of key in use (Export or Signature)
    Dim strSig As String 'the value of the signature
    Dim lngTheKeyLength As Long 'key length
'===============================================================================================================================================

'以下变量数用来进行压缩（compression）和解压缩（decompression）
'===============================================================================================================================================
    Dim lngCompressedSize As Long
    Dim lngDecompressedSize As Long
'===============================================================================================================================================

'以下枚举数据类型用来进行压缩（compression）和解压缩（decompression）
'===============================================================================================================================================
    Enum CZErrors
        Z_OK = 0
        Z_STREAM_END = 1
        Z_NEED_DICT = 2
        Z_ERRNO = -1
        Z_STREAM_ERROR = -2
        Z_DATA_ERROR = -3
        Z_MEM_ERROR = -4
        Z_BUF_ERROR = -5
        Z_VERSION_ERROR = -6
    End Enum
    
    Enum CompressionLevels
        Z_NO_COMPRESSION = 0
        Z_BEST_SPEED = 1
        'note that levels 2-8 exist, too
        Z_BEST_COMPRESSION = 9
        Z_DEFAULT_COMPRESSION = -1
    End Enum
'===============================================================================================================================================

'These types are included for your reference so you can see what is in the PUBLICKEYBLOB and PRIVATEKEYBLOB.
'They are not used by this class so are commented out.  I converted them from the C declarations so some of
'the variable types (As String, etc.) may be incorrect since I haven't tested them.

Private Type PUBLICKEYSTRUC 'for encryption/decryption
    bType As String
    bVersion As String
    reserved As Integer
    aiKeyAlg As Long
End Type

Private Type RSAPUBKEY 'for encryption/decryption
    magic As Long
    bitlen As Long
    pubexp As Long
End Type

Private Type PUBLICKEYBLOB 'for encryption/decryption
    publickeystructure As PUBLICKEYSTRUC
    rsapubkeystructure As RSAPUBKEY
    modulus As String
End Type

Private Type PRIVATEKEYBLOB 'for encryption/decryption
    publickeystructure As PUBLICKEYSTRUC
    rsapubkeystructure As RSAPUBKEY
    modulus As String
    prime1 As String
    prime2 As String
    exponent1 As String
    exponent2 As String
    coefficient As String
    privateExponent As String
End Type


'************************************************************************
'以下第一部分的属性和函数用来进行加密和解密
'This first set of properties and functions are for ENCRYPTION/DECRYPTION
'************************************************************************

Public Property Get ValueSALT() As String
    'holds the current SALT.  In a production app this should be
    'saved as plaintext along with the encrypted file.  See notes in the code below.
    ValueSALT = strSALT
End Property

Public Property Let ValueSALT(strValue As String)
    strSALT = String(Len(strValue), vbNullChar) 'initialize string for use by API
    strSALT = strValue
End Property

Public Property Get ValuePublicPrivateKey() As String
    'the value of the private key in BLOB format.
    'Note that the CryptoAPI also stores the Public key with the Private Key.
    ValuePublicPrivateKey = strPublicPrivateBlob
End Property

Public Property Let ValuePublicPrivateKey(strValue As String)
    strPublicPrivateBlob = String(Len(strValue), vbNullChar) 'initialize string for use by API
    strPublicPrivateBlob = strValue
    strPublicBlob = vbNullString 'if you set PublicPrivate make Private null
End Property

Public Property Get ValuePublicKey() As String
    'the value of the public key in BLOB format this is the key you can send to other people.
    ValuePublicKey = strPublicBlob
End Property

Public Property Let ValuePublicKey(strValue As String)
    strPublicBlob = String(Len(strValue), vbNullChar) 'initialize string for use by API
    strPublicBlob = strValue
    strPublicPrivateBlob = vbNullString 'if you set Public make PublicPrivate null
End Property

Public Property Get ValueSessionKey() As String
    'holds the encrypted session key used during key pair encryption/decryption.
    ValueSessionKey = strSessionBlob
End Property

Public Property Let ValueSessionKey(strValue As String)
    strSessionBlob = String(Len(strValue), vbNullChar) 'initialize string for use by API
    strSessionBlob = strValue
End Property

Public Property Get ValueSignature() As String
    'holds the current signature.  In a production app this should be
    'saved as along with the file.  See notes in the code below.
    ValueSignature = strSig
End Property

Public Property Let ValueSignature(strValue As String)
    strSig = String(Len(strValue), vbNullChar) 'initialize string for use by API
    strSig = strValue
End Property

Public Property Get KeyLength() As Long
    'key length
    KeyLength = lngTheKeyLength / 65536
End Property

Public Property Let KeyLength(lngValue As Long)
    If (lngValue * 65536) = KEY_LENGTH_512 Or KEY_LENGTH_1024 Or KEY_LENGTH_2048 Or KEY_LENGTH_4096 Or KEY_LENGTH_8192 Or KEY_LENGTH_16384 Then
        lngTheKeyLength = lngValue * 65536
    Else
        lngTheKeyLength = KEY_LENGTH_512
    End If
End Property

Public Sub EncryptFile(ByVal SourceFile As String, ByVal DestFile As String, ByVal Password As String)
    'single key file encryption
    Dim intNextFreeFile As Integer
    Dim arrByteArray() As Byte