1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139
| Option Explicit
'Déclaration
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
'Variable
Dim lngCompressedSize As Long
Dim lngDecompressedSize As Long
Enum CZErrors 'Constante pour la compression/décompression
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 'Constante pour la compression/décompression
Z_NO_COMPRESSION = 0
Z_BEST_SPEED = 1
'Les Levels 2-8 existe aussi
Z_BEST_COMPRESSION = 9
Z_DEFAULT_COMPRESSION = -1
End Enum
Public Property Get ValueCompressedSize() As Long
'Taille de l'objet après compression
ValueCompressedSize = lngCompressedSize
End Property
Private Property Let ValueCompressedSize(ByVal New_ValueCompressedSize As Long)
lngCompressedSize = New_ValueCompressedSize
End Property
Public Function CompressByteArray(TheData() As Byte, CompressionLevel As Integer) As Long
'compresse 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 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
Close #10
intNextFreeFile = FreeFile '10 '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 0
'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
End Function |
Partager