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 |
envoie de fichier via le port série
Répondre avec citation
Balises[CODE]...[/CODE]
en fin de discussion, quand vous avez obtenu l'aide attendue.
......... et pourquoi pas, pour remercier, un 
pour celui/ceux qui vous ont dépannés.
Envoyé par OhMonBato
Partager