Programming language:VBA

vba compress string

Code: VBA

2021-02-12 13:11:16

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/

Stevo

Code: VBA

2021-08-10 03:05:05

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/

New to Communities?

Join the community

vba compress string

Tags

Related

New to Communities?