Code:
Option Compare Database
Option Explicit
' https://www.codegrepper.com/code-examples/vb/excel+vba+compress+string
Private Declare PtrSafe Function compress Lib "cabinet" Alias "Compress" (ByVal hCompressor As Long, ByVal pUncompressedData As LongPtr, ByVal sizeUncompressedData As Long, ByVal pCompressedDataBuffer As LongPtr, ByVal sizeCompressedBuffer As Long, ByVal bytesOut As Long) As Long
Private Declare PtrSafe Function Decompress Lib "cabinet" (ByVal hCompressor As Long, ByVal pCompressedData As LongPtr, ByVal sizeCompressedData As Long, ByVal pUncompressedDataBuffer As LongPtr, ByVal sizeOfUncompressedBuffer As Long, ByVal bytesOut As Long) As Long
Private Declare PtrSafe Function CreateCompressor Lib "cabinet" (ByVal CompressAlgorithm As Long, ByVal pAllocationRoutines As Long, hCompressor As Long) As Long
Private Declare PtrSafe Function CreateDecompressor Lib "cabinet" (ByVal CompressAlgorithm As Long, ByVal pAllocationRoutines As Long, hDecompressor As Long) As Long
Private Declare PtrSafe Function CloseCompressor Lib "cabinet" (ByVal hCompressor As Long) As Long
Private Declare PtrSafe Function CloseDecompressor Lib "cabinet" (ByVal hDecompressor As Long) As Long
Function CompressString$(s$, Optional algorithm& = 5)
Dim h As Long, max As Long, bytesOut As Long, b As String
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 As Long, bytesOut As Long, b As String
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
Sub TestCompressString()
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)
Debug.Print Len(GreenEggs) & ": " & GreenEggs '<--displays: 187
Debug.Print Len(Tiny) & ": " & Tiny '<--displays: 73
Debug.Print Len(Roundtrip) & ": " & Roundtrip '<--displays: 187 '<--displays Dr. Seus's breakfast problem
End Sub
When I try