excel vba string compression
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function Compress& Lib "cabinet" (ByVal hCompressor&, ByVal pUncompressedData&, ByVal sizeUncompressedData&, ByVal pCompressedDataBuffer&, ByVal sizeCompressedBuffer&, bytesOut&)
Private Declare PtrSafe Function Decompress& Lib "cabinet" (ByVal hCompressor&, ByVal pCompressedData&, ByVal sizeCompressedData&, ByVal pUncompressedDataBuffer&, ByVal sizeOfUncompressedBuffer&, bytesOut&)
Private Declare PtrSafe Function CreateCompressor& Lib "cabinet" (ByVal CompressAlgorithm&, ByVal pAllocationRoutines&, hCompressor&)
Private Declare PtrSafe Function CreateDecompressor& Lib "cabinet" (ByVal CompressAlgorithm&, ByVal pAllocationRoutines&, hDecompressor&)
Private Declare PtrSafe Function CloseCompressor& Lib "cabinet" (ByVal hCompressor&)
Private Declare PtrSafe Function CloseDecompressor& Lib "cabinet" (ByVal hDecompressor&)
#Else
Private Declare Function Compress& Lib "cabinet" (ByVal hCompressor&, ByVal pUncompressedData&, ByVal sizeUncompressedData&, ByVal pCompressedDataBuffer&, ByVal sizeCompressedBuffer&, bytesOut&)
Private Declare Function Decompress& Lib "cabinet" (ByVal hCompressor&, ByVal pCompressedData&, ByVal sizeCompressedData&, ByVal pUncompressedDataBuffer&, ByVal sizeOfUncompressedBuffer&, bytesOut&)
Private Declare Function CreateCompressor& Lib "cabinet" (ByVal CompressAlgorithm&, ByVal pAllocationRoutines&, hCompressor&)
Private Declare Function CreateDecompressor& Lib "cabinet" (ByVal CompressAlgorithm&, ByVal pAllocationRoutines&, hDecompressor&)
Private Declare Function CloseCompressor& Lib "cabinet" (ByVal hCompressor&)
Private Declare Function CloseDecompressor& Lib "cabinet" (ByVal hDecompressor&)
#End If
Function CompressString$(s$, Optional algorithm& = 5)
Dim h&, max&, bytesOut&, b$
If Len(s) Then
If CreateCompressor(algorithm, 0&, h) Then
max = LenB(s): b = Space$(max)
If Compress(h, StrPtr(s), max, StrPtr(b), max, bytesOut) Then
If bytesOut Then CompressString = Left$(b, bytesOut \ 2)
End If
CloseCompressor h
End If
End If
End Function
Function DecompressString$(s$, Optional algorithm& = 5)
Dim h&, bytesOut&, b$
If Len(s) Then
If CreateDecompressor(algorithm, 0&, h) Then
b = Space$(LenB(s) * 50)
If Decompress(h, StrPtr(s), LenB(s), StrPtr(b), LenB(b), bytesOut) Then
If bytesOut Then DecompressString = Left$(b, bytesOut \ 2)
End If
CloseDecompressor h
End If
End If
End Function
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Dim GreenEggs$, Tiny$, Roundtrip$
GreenEggs = "I do not like them in a box. I do not like them with a fox. I will not eat them in a house. I do not like them with a mouse. I do not like them here or there. I do not like them ANYWHERE!"
Tiny = CompressString(GreenEggs)
Roundtrip = DecompressString(Tiny)
MsgBox Len(GreenEggs) '<--displays: 187
MsgBox Len(Tiny) '<--displays: 73
MsgBox Len(Roundtrip) '<--displays: 187
Debug.Print Roundtrip '<--displays Dr. Seus's breakfast problem
'Note: Tiny (the compressed string) can be written to disk and decompressed
' at a later date.
'Note: These functions use the Win32 Compression API, which is bundled with
'Windows since Windows 8. These function will not work on Windows 7 and earlier.
'Note: These functons default to using Algorithm #5: LZMS. The functions can
' optionally be directed to use the other supported MS API
' compression algorithms:
' MSZIP: 2
' XPRESS: 3
' XPRESS_HUFF: 4
' LZMS: 5
'Note: There is no Algorithm #1 included in the API.
'Note: The default LZMS compression algorithm seems to compress the best.
'Reference:
' https://docs.microsoft.com/en-us/windows/win32/api/_cmpapi/