vba text 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/
