Работа с zip архивами

Option Explicit
Enum Compess_Algorithm
'    COMPRESS_ALGORITHM_MSZIP = 2 'не поддерживается
    COMPRESS_ALGORITHM_XPRESS = 3
    COMPRESS_ALGORITHM_XPRESS_HUFF = 4
    COMPRESS_ALGORITHM_LZMS = 5
End Enum
'#If VBA7 Then
'    Private Declare PtrSafe Function Compress& Lib "cabinet" (ByVal hCompressor&, pUncompressedData As Any, ByVal sizeUncompressedData&, pCompressedDataBuffer As Any, ByVal sizeCompressedBuffer&, bytesOut&)
'    Private Declare PtrSafe Function Decompress& Lib "cabinet" (ByVal hCompressor&, pCompressedData As Any, ByVal sizeCompressedData&, pUncompressedDataBuffer As Any, ByVal sizeOfUncompressedBuffer&, bytesOut&)
'    Private Declare PtrSafe Function CreateCompressor& Lib "cabinet" (ByVal CompressAlgorithm As Compess_Algorithm, ByVal pAllocationRoutines&, hCompressor&)
'    Private Declare PtrSafe Function CreateDecompressor& Lib "cabinet" (ByVal CompressAlgorithm As Compess_Algorithm, 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&, pUncompressedData As Any, ByVal sizeUncompressedData&, pCompressedDataBuffer As Any, ByVal sizeCompressedBuffer&, bytesOut&)
    Private Declare Function Decompress& Lib "cabinet" (ByVal hCompressor&, pCompressedData As Any, ByVal sizeCompressedData&, pUncompressedDataBuffer As Any, ByVal sizeOfUncompressedBuffer&, bytesOut&)
    Private Declare Function CreateCompressor& Lib "cabinet" (ByVal CompressAlgorithm As Compess_Algorithm, ByVal pAllocationRoutines&, hCompressor&)
    Private Declare Function CreateDecompressor& Lib "cabinet" (ByVal CompressAlgorithm As Compess_Algorithm, ByVal pAllocationRoutines&, hDecompressor&)
    Private Declare Function CloseCompressor& Lib "cabinet" (ByVal hCompressor&)
    Private Declare Function CloseDecompressor& Lib "cabinet" (ByVal hDecompressor&)
'#End If
Enum NtCompressionStatus
    STATUS_SUCCESS& = 0
    STATUS_BAD_COMPRESSION_BUFFER& = &HC0000242   '-1073741246
    STATUS_UNSUPPORTED_COMPRESSION& = &HC000025F  '-1073741217
    STATUS_INVALID_PARAMETER& = &HC000000D        '-1073741811
    STATUS_BUFFER_ALL_ZEROS = &H117               '279
    STATUS_NOT_SUPPORTED = &HC00000BB             '-1073741637
    STATUS_BUFFER_TOO_SMALL = &HC0000023          '-1073741789
End Enum
Private Declare Function RtlGetCompressionWorkSpaceSize Lib "ntdll" (ByVal CompressionFormatAndEngine As Integer, ByRef CompressBufferWorkSpaceSize As Long, ByRef CompressFragmentWorkSpaceSize As Long) As NtCompressionStatus
Private Declare Function RtlCompressBuffer Lib "ntdll" (ByVal CompressionFormatAndEngine As Integer, ByRef UncompressedBuffer As Any, ByVal UncompressedBufferSize As Long, ByRef CompressedBuffer As Any, ByVal CompressedBufferSize As Long, ByVal UncompressedChunkSize As Long, ByRef FinalCompressedSize As Long, ByRef WorkSpace As Any) As NtCompressionStatus
Private Declare Function RtlDecompressBuffer Lib "ntdll" (ByVal CompressionFormat As Integer, ByRef ptrDestBuffer As Any, ByVal DestBufferSize As Long, ByRef ptrSrceBuffer As Any, ByVal SceBufferSize As Long, ByRef pDestinationSize As Long) As NtCompressionStatus
 
Private Const COMPRESSION_FORMAT_LZNT1& = 2
Private Const nullPtr As LongPtr = 0
 
Private Function Compress_NT(bInp() As Byte, bOut() As Byte) As NtCompressionStatus
    On Error GoTo Quit
    Dim WorkSpace() As Byte
    Dim szWorkSpace As Long
    Dim bInpSize As Long
    Dim bOutSize As Long
    
    Compress_NT = RtlGetCompressionWorkSpaceSize(COMPRESSION_FORMAT_LZNT1, szWorkSpace, 0)
    If Compress_NT = STATUS_SUCCESS Then
        bInpSize = UBound(bInp) + 1
        ReDim WorkSpace(szWorkSpace - 1)
        ReDim bOut(bInpSize - 1)
        
        Compress_NT = RtlCompressBuffer(COMPRESSION_FORMAT_LZNT1, bInp(0), bInpSize, bOut(0), bInpSize, 4096, bOutSize, WorkSpace(0))
        If Compress_NT = STATUS_SUCCESS Then ReDim Preserve bOut(bOutSize - 1)
    End If
Quit:
End Function
Public Function DeCompress_NT(bInp() As Byte, bOut() As Byte, Optional ByVal bOutSize As Long) As NtCompressionStatus
    On Error GoTo Quit
    Dim bInpSize As Long
    Dim returnedSize As Long
    
    bInpSize = UBound(bInp) + 1
    If bOutSize = 0 Then bOutSize = bInpSize * 2
    ReDim bOut(bOutSize - 1)
    
    Do
        DeCompress_NT = RtlDecompressBuffer(COMPRESSION_FORMAT_LZNT1, bOut(0), bOutSize, bInp(0), bInpSize, returnedSize)
        Select Case DeCompress_NT
        Case STATUS_SUCCESS
            ReDim Preserve bOut(returnedSize - 1)
            Exit Do
        Case STATUS_BAD_COMPRESSION_BUFFER
            bOutSize = bOutSize + bInpSize
            ReDim Preserve bOut(bOutSize - 1)
        Case Else 'STATUS_UNSUPPORTED_COMPRESSION
            Exit Do
        End Select
    Loop
Quit:
End Function
Function CabCompress(bInp() As Byte, Optional ByVal algorithm As Compess_Algorithm = COMPRESS_ALGORITHM_LZMS) As Byte()
    Dim h&, max&, bytesOut&, bOut() As Byte
    
    If CreateCompressor(algorithm, 0, h) Then
        max = UBound(bInp) + 1: ReDim bOut(max - 1)
        If Compress(h, bInp(0), max, bOut(0), max, bytesOut) Then
            If bytesOut Then ReDim Preserve bOut(bytesOut - 1)
        End If
        CloseCompressor h
    End If
    
    CabCompress = bOut
End Function
Function CabDecompress(bInp() As Byte, Optional ByVal algorithm As Compess_Algorithm = COMPRESS_ALGORITHM_LZMS) As Byte()
    Dim h&, bytesOut&, bOut() As Byte
    
    If CreateDecompressor(algorithm, 0, h) Then
        Decompress h, bInp(0), UBound(bInp) + 1, ByVal StrPtr(vbNullString), 0, bytesOut
        If bytesOut Then
            ReDim bOut(bytesOut - 1)
            Decompress h, bInp(0), UBound(bInp) + 1, bOut(0), bytesOut, ByVal StrPtr(vbNullString)
        End If
        CloseDecompressor h
    End If
    
    CabDecompress = bOut
End Function
Private Function GetFile(sFlPt As String) As Byte()
    Dim fNum&, fLen&, bBuf() As Byte
    fNum = FreeFile
    Open sFlPt For Binary Access Read As #fNum
    fLen = LOF(fNum)
    If fLen Then
        ReDim bBuf(fLen - 1)
        Get fNum, , bBuf
    End If
    Close fNum
    GetFile = bBuf
End Function
 
Sub CompressionTest()
    Dim bFile() As Byte, bCompNt() As Byte, bCompCab() As Byte
    
'    bFile = "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!"
    bFile = GetFile("D:\tmp\Zip\Diletant\Simpler Zipper Demo_\Subfolder\zlibwapi.dll")
    
    Compress_NT bFile, bCompNt
    bCompCab = CabCompress(bFile)
    Debug.Print "Размер данных:  "; UBound(bFile) + 1
    Debug.Print "NT-кмопрессия:  "; UBound(bCompNt) + 1
    Debug.Print "Cab-компрессия: "; UBound(bCompCab) + 1
    Debug.Print
End Sub