clscompress.cls

此为水费收费管理系统

    arrByteArray(UBound(arrByteArray)) = Len(strSig) 'length of blob is last character
    intNextFreeFile = FreeFile
    Open DestFile For Binary As #intNextFreeFile
    Put #intNextFreeFile, , arrByteArray()
    Close #intNextFreeFile
End Sub

Public Function ValidateFile_KeyPair(ByVal SourceFile As String, ByVal DestFile As String)
    'key pair file signature validation
    Dim intNextFreeFile As Integer
    Dim arrByteArray() As Byte
    Dim x As Long
    Dim y As Long
    'reset the strSig value
    strSig = ""
    '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 strSig
    '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
        strSig = strSig & Chr(arrByteArray(x))
    Next x
    ReDim Preserve arrByteArray(0 To (UBound(arrByteArray) - Len(strSig) - 1))
    'Decrypt the arrByteArray
    ValidateByteArray_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 SignByteArray_KeyPair(ByRef arrByteArray() As Byte)
    'key pair byte array signing
    Dim strInput As String
    Dim strOutput As String
    strInput = StrConv(arrByteArray(), vbUnicode) 'convert to string
    strOutput = SignValidate_KeyPair(strInput, True) 'return the signature
    arrByteArray() = StrConv(strOutput, vbFromUnicode) 'convert to byte array
End Function

Public Function ValidateByteArray_KeyPair(ByRef arrByteArray() As Byte)
    'key pair byte array signing
    Dim strInput As String
    Dim strOutput As String
    strInput = StrConv(arrByteArray(), vbUnicode) 'convert to string
    strOutput = SignValidate_KeyPair(strInput, False) 'return the signature
    arrByteArray() = StrConv(strOutput, vbFromUnicode) 'convert to byte array
End Function

Public Function SignString_KeyPair(ByVal Text As String) As String
    'key pair string signing
    SignString_KeyPair = SignValidate_KeyPair(Text, True)
End Function

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

Public Function ListAvailableProviders() As String
    'list the providers available on the system.  Useful for finding
    'out if the Enhanced CSP is available.
    Dim lngIndex As Long
    Dim lngReturnValue As Long
    Dim lngProvType As Long
    Dim strProvName As String
    Dim lngProvNameData As Long
    'initialize a few variables
    lngIndex = 0
    ListAvailableProviders = ""
    On Error GoTo ErrorTrap
    Do
        lngReturnValue = CryptEnumProviders(lngIndex, vbNull, 0, lngProvType, vbNull, lngProvNameData)
        strProvName = String(lngProvNameData, vbNullChar)
        lngReturnValue = CryptEnumProviders(lngIndex, vbNull, 0, lngProvType, strProvName, lngProvNameData)
        ListAvailableProviders = ListAvailableProviders & strProvName & " " & lngProvType & vbNewLine
    Loop While lngReturnValue
    Exit Function
ErrorTrap:
    ListAvailableProviders = "Function supposedly only supported in Windows 98 and Windows 2000."
End Function


'************************************************************************
'以下第二部分的属性和函数用来进行压缩和解压缩
' All properties and functions below this line are for COMPRESSION/DECOMPRESSION
'************************************************************************

Public Property Get ValueCompressedSize() As Long
    'size of an object after compression
    ValueCompressedSize = lngCompressedSize
End Property

Private Property Let ValueCompressedSize(ByVal New_ValueCompressedSize As Long)
    lngCompressedSize = New_ValueCompressedSize
End Property

Public Property Get ValueDecompressedSize() As Long
    'size of an object after decompression
    ValueDecompressedSize = lngDecompressedSize
End Property

Private Property Let ValueDecompressedSize(ByVal New_ValueDecompressedSize As Long)
    lngDecompressedSize = New_ValueDecompressedSize
End Property

Public Function CompressByteArray(TheData() As Byte, CompressionLevel As Integer) As Long
    'compress a byte array
    Dim lngResult As Long
    Dim lngBufferSize As Long
    Dim arrByteArray() As Byte
    lngDecompressedSize = UBound(TheData) + 1
    'Allocate memory for byte array
    lngBufferSize = UBound(TheData) + 1
    lngBufferSize = lngBufferSize + (lngBufferSize * 0.01) + 12
    ReDim arrByteArray(lngBufferSize)
    'Compress byte array (data)
    lngResult = compress2(arrByteArray(0), lngBufferSize, TheData(0), UBound(TheData) + 1, CompressionLevel)
    'Truncate to compressed size
    ReDim Preserve TheData(lngBufferSize - 1)
    CopyMemory TheData(0), arrByteArray(0), lngBufferSize
    'Set property
    lngCompressedSize = UBound(TheData) + 1
    'return error code (if any)
    CompressByteArray = lngResult
End Function

Public Function CompressString(Text As String, CompressionLevel As Integer) As Long
    'compress a string
    Dim lngOrgSize As Long
    Dim lngReturnValue As Long
    Dim lngCmpSize As Long
    Dim strTBuff As String
    ValueDecompressedSize = Len(Text)
    'Allocate string space for the buffers
    lngOrgSize = Len(Text)
    strTBuff = String(lngOrgSize + (lngOrgSize * 0.01) + 12, 0)
    lngCmpSize = Len(strTBuff)
    'Compress string (temporary string buffer) data
    lngReturnValue = compress2(ByVal strTBuff, lngCmpSize, ByVal Text, Len(Text), CompressionLevel)
    'Crop the string and set it to the actual string.
    Text = Left$(strTBuff, lngCmpSize)
    'Set compressed size of string.
    ValueCompressedSize = lngCmpSize
    'Cleanup
    strTBuff = ""
    'return error code (if any)
    CompressString = lngReturnValue
End Function

Public Function DecompressByteArray(TheData() As Byte, OriginalSize As Long) As Long
    'decompress a byte array
    Dim lngResult As Long
    Dim lngBufferSize As Long
    Dim arrByteArray() As Byte
    lngDecompressedSize = OriginalSize
    lngCompressedSize = UBound(TheData) + 1
    'Allocate memory for byte array
    lngBufferSize = OriginalSize
    lngBufferSize = lngBufferSize + (lngBufferSize * 0.01) + 12
    ReDim arrByteArray(lngBufferSize)
    'Decompress data
    lngResult = uncompress(arrByteArray(0), lngBufferSize, TheData(0), UBound(TheData) + 1)
    'Truncate buffer to compressed size
    ReDim Preserve TheData(lngBufferSize - 1)
    CopyMemory TheData(0), arrByteArray(0), lngBufferSize
    'return error code (if any)
    DecompressByteArray = lngResult
End Function

Public Function DecompressString(Text As String, OriginalSize As Long) As Long
    'decompress a string
    Dim lngResult As Long
    Dim lngCmpSize As Long
    Dim strTBuff As String
    'Allocate string space
    strTBuff = String(ValueDecompressedSize + (ValueDecompressedSize * 0.01) + 12, 0)
    lngCmpSize = Len(strTBuff)
    ValueDecompressedSize = OriginalSize
    'Decompress
    lngResult = uncompress(ByVal strTBuff, lngCmpSize, ByVal Text, Len(Text))
    'Make string the size of the uncompressed string
    Text = Left$(strTBuff, lngCmpSize)
    ValueCompressedSize = lngCmpSize
    'return error code (if any)
    DecompressString = lngResult
End Function

Public Function CompressFile(FilePathIn As String, FilePathOut As String, CompressionLevel As Integer) As Long
    'compress a file
    Dim intNextFreeFile As Integer
    Dim TheBytes() As Byte
    Dim lngResult As Long
    Dim lngFileLen As Long
    lngFileLen = FileLen(FilePathIn)
    'allocate byte array
    ReDim TheBytes(lngFileLen - 1)
    'read byte array from file
    intNextFreeFile = FreeFile
    Open FilePathIn For Binary Access Read As #intNextFreeFile
        Get #intNextFreeFile, , TheBytes()
    Close #intNextFreeFile
    'compress byte array
    lngResult = CompressByteArray(TheBytes(), CompressionLevel)
    'kill any file in place
    On Error Resume Next
    Kill FilePathOut
    On Error GoTo Er
    'Write it out
    intNextFreeFile = FreeFile
    Open FilePathOut For Binary Access Write As #intNextFreeFile
        Put #intNextFreeFile, , lngFileLen 'must store the length of the original file
        Put #intNextFreeFile, , TheBytes()
    Close #intNextFreeFile
    Erase TheBytes
    CompressFile = lngResult
    Exit Function
Er:
    Erase TheBytes
    If Err.Number = 76 Then
        CompressFile = 9999
    Else
        CompressFile = 99999
    End If
End Function

Public Function DecompressFile(FilePathIn As String, FilePathOut As String) As Long
    'decompress a file
    Dim intNextFreeFile As Integer
    Dim TheBytes() As Byte
    Dim lngResult As Long
    Dim lngFileLen As Long
    'allocate byte array
    ReDim TheBytes(FileLen(FilePathIn) - 1)
    'read byte array from file
    intNextFreeFile = FreeFile
    Open FilePathIn For Binary Access Read As #intNextFreeFile
        Get #intNextFreeFile, , lngFileLen 'the original (uncompressed) file's length
        Get #intNextFreeFile, , TheBytes()
    Close #intNextFreeFile
    'decompress
    lngResult = DecompressByteArray(TheBytes(), lngFileLen)
    'kill any file already there
    On Error Resume Next
    Kill FilePathOut
    On Error GoTo Er
    'Write it out
    intNextFreeFile = FreeFile
    Open FilePathOut For Binary Access Write As #intNextFreeFile
        Put #intNextFreeFile, , TheBytes()
    Close #intNextFreeFile
    Erase TheBytes
    DecompressFile = lngResult
    Exit Function
Er:
    Erase TheBytes
    If Err.Number = 76 Then
        DecompressFile = 9999
    Else
        DecompressFile = 99999
    End If
End Function