-
Notifications
You must be signed in to change notification settings - Fork 1
/
modAPI_vbaSquash.bas
187 lines (155 loc) · 10.2 KB
/
modAPI_vbaSquash.bas
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
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
Attribute VB_Name = "modAPI_vbaSquash"
' _
||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||| ' _
|||||||||||||||||||||||||| |||||||||||||||||||||||||||||||||| ' _
|||||||||||||||||||||||||| vbaSquash (v1) |||||||||||||||||||||||||||||||||| ' _
|||||||||||||||||||||||||| |||||||||||||||||||||||||||||||||| ' _
|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
' _
AUTHOR: Kallun Willock
' _
URL: MS - https://docs.microsoft.com/en-us/windows/win32/api/_cmpapi/
' _
NOTES: Uses Win32 APIs in the cabinet.dll library to compress and decompress bytes. ' _
Only available on Windows 8+, and will not work on OS up to (and including) Win7.
' _
LICENSE: MIT ' _
' _
VERSION: 1.0 02/04/2024
Option Explicit
Public Enum COMPRESS_ALGORITHM_ENUM
MSZIP = 2
XPRESS = 3
XPRESS_HUFF = 4
LZMS = 5
End Enum
#If VBA7 Then
Private Declare PtrSafe Function CreateCompressor Lib "cabinet.dll" (ByVal CompressionAlgorithm As COMPRESS_ALGORITHM_ENUM, ByVal AllocationRoutines As Long, ByRef hCompressor As LongPtr) As Long
Private Declare PtrSafe Function Compress Lib "cabinet.dll" (ByVal hCompressor As LongPtr, ByVal UncompressedData As LongPtr, ByVal UncompressedDataSize As Long, ByVal CompressedBuffer As LongPtr, ByVal CompressedBufferSize As Long, ByRef CompressedBufferSize As Long) As Long
Private Declare PtrSafe Function CloseCompressor Lib "cabinet.dll" (ByVal hCompressor As LongPtr) As Long
Private Declare PtrSafe Function CreateDecompressor Lib "cabinet.dll" (ByVal CompressionAlgorithm As COMPRESS_ALGORITHM_ENUM, ByVal AllocationRoutines As Long, ByRef hDecompressor As LongPtr) As Long
Private Declare PtrSafe Function Decompress Lib "cabinet.dll" (ByVal hCompressor As LongPtr, ByVal CompressedData As LongPtr, ByVal CompressedDataSize As Long, ByVal UncompressedBuffer As LongPtr, ByVal UncompressedBufferSize As Long, ByRef UncompressedDataSize As Long) As Long
Private Declare PtrSafe Function CloseDecompressor Lib "cabinet.dll" (ByVal hDecompressor As LongPtr) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function CreateCompressor Lib "cabinet.dll" (ByVal CompressionAlgorithm As COMPRESS_ALGORITHM_ENUM, ByVal AllocationRoutines As Long, ByRef hCompressor As LongPtr) As Long
Private Declare Function Compress Lib "cabinet.dll" (ByVal hCompressor As LongPtr, ByVal UncompressedData As LongPtr, ByVal UncompressedDataSize As Long, ByVal CompressedBuffer As LongPtr, ByVal CompressedBufferSize As Long, ByRef CompressedBufferSize As Long) As Long
Private Declare Function CloseCompressor Lib "cabinet.dll" (ByVal hCompressor As LongPtr) As Long
Private Declare Function CreateDecompressor Lib "cabinet.dll" (ByVal CompressionAlgorithm As COMPRESS_ALGORITHM_ENUM, ByVal AllocationRoutines As Long, ByRef hDecompressor As LongPtr) As Long
Private Declare Function Decompress Lib "cabinet.dll" (ByVal hCompressor As LongPtr, ByVal CompressedData As LongPtr, ByVal CompressedDataSize As Long, ByVal UncompressedBuffer As LongPtr, ByVal UncompressedBufferSize As Long, ByRef UncompressedDataSize As Long) As Long
Private Declare Function CloseDecompressor Lib "cabinet.dll" (ByVal hDecompressor As LongPtr) As Long
#End If
Public Function CompressBytes(ByRef Source() As Byte, _
Optional ByVal Algorithm As COMPRESS_ALGORITHM_ENUM = LZMS) _
As Byte()
If VBA.LenB(Source(0)) Then
Dim Result As Long, hCompressor As LongPtr
Result = CreateCompressor(Algorithm, 0, hCompressor)
On Error GoTo ErrHandler
If Result <> 0 Then
Dim ByteLength As Long, Data As Long
ByteLength = VBA.LenB(Source)
ReDim Buffer(ByteLength - 1) As Byte
If Compress(hCompressor, VarPtr(Source(0)), ByteLength, VarPtr(Buffer(0)), ByteLength, Data) Then
If Data Then CompressBytes = VBA.LeftB(Buffer, Data)
End If
ErrHandler:
CloseCompressor hCompressor
End If
Erase Buffer
End If
End Function
Public Function DecompressBytes(ByRef Source() As Byte, _
Optional ByVal Algorithm As COMPRESS_ALGORITHM_ENUM = LZMS) _
As Byte()
If VBA.LenB(Source(0)) Then
Dim Result As Long, hCompressor As LongPtr
Result = CreateDecompressor(Algorithm, 0, hCompressor)
On Error GoTo ErrHandler
If Result <> 0 Then
Dim ByteLength As Long, Data As Long
ReDim Buffer(0) As Byte
ByteLength = VBA.LenB(Source)
If Decompress(hCompressor, VarPtr(Source(0)), ByteLength, VarPtr(Buffer(0)), 0, Data) = 0 Then
ReDim Buffer(Data - 1)
If Decompress(hCompressor, VarPtr(Source(0)), ByteLength, VarPtr(Buffer(0)), Data, Data) Then
If Data Then DecompressBytes = VBA.LeftB(Buffer, Data)
End If
End If
ErrHandler:
CloseDecompressor hCompressor
End If
Erase Buffer
End If
End Function
Public Function CompressString(ByVal Target As String, _
Optional ByVal Algorithm As COMPRESS_ALGORITHM_ENUM = LZMS) _
As String
If VBA.LenB(Target) Then
Dim TempBytes() As Byte
TempBytes = Target
CompressString = CompressBytes(TempBytes, Algorithm)
End If
End Function
Public Function DecompressString(ByVal Target As String, _
Optional ByVal Algorithm As COMPRESS_ALGORITHM_ENUM = LZMS) _
As String
If VBA.LenB(Target) Then
Dim TempBytes() As Byte
TempBytes = Target
DecompressString = DecompressBytes(TempBytes, Algorithm)
End If
End Function
Public Function CompressFile(ByVal TargetFilename As String, _
Optional ByVal CreateNewFile As Boolean = True, _
Optional ByVal Algorithm As COMPRESS_ALGORITHM_ENUM = LZMS) _
As String
If VBA.LenB(Dir(TargetFilename)) Then
Dim FileBytes() As Byte, CompressedData() As Byte
FileBytes = ReadFile(TargetFilename)
CompressedData = CompressBytes(FileBytes, Algorithm)
If CreateNewFile Then TargetFilename = TargetFilename & "_COMPRESSED"
Call WriteFile(TargetFilename, CompressedData, Not (CreateNewFile))
End If
End Function
Public Function DecompressFile(ByVal TargetFilename As String, _
Optional ByVal CreateNewFile As Boolean = True, _
Optional ByVal Algorithm As COMPRESS_ALGORITHM_ENUM = LZMS) _
As String
If VBA.LenB(Dir(TargetFilename)) Then
Dim FileBytes() As Byte, CompressedData() As Byte
FileBytes = ReadFile(TargetFilename)
CompressedData = DecompressBytes(FileBytes, Algorithm)
If CreateNewFile Then TargetFilename = TargetFilename & "_DECOMPRESSED"
If WriteFile(TargetFilename, CompressedData, Not (CreateNewFile)) = 0 Then
MsgBox "Compression Fail"
End If
End If
End Function
Public Function ReadFile(ByVal TargetFilename As String) As Byte()
If VBA.LenB(Dir(TargetFilename)) Then
Dim FileNum As Long, TempData() As Byte
FileNum = FreeFile
Open TargetFilename For Binary Access Read As #FileNum
ReDim TempData(0 To LOF(FileNum) - 1&) As Byte
Get #FileNum, , TempData
Close #FileNum
ReadFile = TempData
Erase TempData
End If
End Function
Public Function WriteFile(ByVal TargetFilename As String, _
ByRef FileData() As Byte, _
Optional ByVal DeleteExisting As Boolean = True) _
As Long
If VBA.LenB(Dir(TargetFilename)) Then
If DeleteExisting Then VBA.Kill TargetFilename Else Exit Function
End If
Dim FileNum As Long
FileNum = FreeFile
Open TargetFilename For Binary Access Write As #FileNum
Put #FileNum, , FileData
Close #FileNum
End Function