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

Option Explicit
Enum apiBOOL
    apiFalse
    apiTrue
End Enum
Enum CabCompressAlgorithm
    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 CabCompressAlgorithm, ByVal pAllocationRoutines&, hCompressor&)
'    Private Declare PtrSafe Function CreateDecompressor& Lib "cabinet" (ByVal CompressAlgorithm As CabCompressAlgorithm, 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 As Long, pUncompressedData As Any, ByVal sizeUncompressedData As Long, pCompressedDataBuffer As Any, ByVal sizeCompressedBuffer As Long, bytesOut As Long) As apiBOOL
    Private Declare Function Decompress Lib "cabinet" (ByVal hCompressor As Long, pCompressedData As Any, ByVal sizeCompressedData As Long, pUncompressedDataBuffer As Any, ByVal sizeOfUncompressedBuffer&, bytesOut As Long) As apiBOOL
    Private Declare Function CreateCompressor Lib "cabinet" (ByVal CompressAlgorithm As CabCompressAlgorithm, ByVal pAllocationRoutines As Long, hCompressor As Long) As apiBOOL
    Private Declare Function CreateDecompressor Lib "cabinet" (ByVal CompressAlgorithm As CabCompressAlgorithm, ByVal pAllocationRoutines As Long, hDecompressor As Long) As apiBOOL
    Private Declare Function CloseCompressor Lib "cabinet" (ByVal hCompressor As Long) As apiBOOL
    Private Declare Function CloseDecompressor Lib "cabinet" (ByVal hDecompressor As Long) As apiBOOL
'#End If
'ntifs.h:
'#define COMPRESSION_FORMAT_NONE         (0x0000)
'#define COMPRESSION_FORMAT_DEFAULT      (0x0001)
'#define COMPRESSION_FORMAT_LZNT1        (0x0002)
'#define COMPRESSION_ENGINE_STANDARD     (0x0000)
'#define COMPRESSION_ENGINE_MAXIMUM      (0x0100)
'#define COMPRESSION_ENGINE_HIBER        (0x0200)
Enum NtCompressionFormat
    COMPRESSION_FORMAT_DEFAULT = &H1
    COMPRESSION_FORMAT_LZNT1 = &H2
    COMPRESSION_FORMAT_XPRESS = &H3
    COMPRESSION_FORMAT_XPRESS_HUFF = &H4
    COMPRESSION_ENGINE_STANDARD = &H0
    COMPRESSION_ENGINE_MAXIMUM = &H100
    COMPRESSION_ENGINE_HIBER = &H200
End Enum
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 NtCompressionFormat, 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 NullPtr As LongPtr = 0
 
Function Compress_NT(bInp() As Byte, bOut() As Byte, CmpFormat As NtCompressionFormat) 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(CmpFormat, szWorkSpace, 0)
    If Compress_NT = STATUS_SUCCESS Then
        bInpSize = UBound(bInp) + 1
        ReDim WorkSpace(szWorkSpace - 1)
        ReDim bOut(bInpSize - 1)
        
        Compress_NT = RtlCompressBuffer(CmpFormat, 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
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 CabCompressAlgorithm = 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 CabCompressAlgorithm = 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
 
Function CompressString(s$, Optional ByVal algorithm As CabCompressAlgorithm = 5) As String
    Dim h&, Max&, bytesOut&, b$
    If Len(s) Then
        If CreateCompressor(algorithm, 0&, h) Then
            Max = LenB(s): b = Space$(Max)
            If Compress(h, ByVal StrPtr(s), Max, ByVal 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 ByVal algorithm As CabCompressAlgorithm = 5) As String
    Dim h&, bytesOut&, b$
    If Len(s) Then
        If CreateDecompressor(algorithm, 0&, h) Then
            b = Space$(LenB(s) * 50)
            If Decompress(h, ByVal StrPtr(s), LenB(s), ByVal StrPtr(b), LenB(b), bytesOut) Then
                If bytesOut Then DecompressString = Left$(b, bytesOut \ 2)
            End If
            CloseDecompressor h
        End If
    End If
End Function
 
Private Function GetFileBytes(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
    GetFileBytes = bBuf
End Function
 
Private Sub Example2()
    Dim bBuf() As Byte, bCompNt() As Byte, bCompCab() As Byte
    
'    bBuf = "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!"
    bBuf = GetFileBytes("D:\tmp\Zip\Diletant\Simpler Zipper Demo_\Subfolder\zlibwapi.dll")
    
    Compress_NT bBuf, bCompNt, COMPRESSION_FORMAT_XPRESS_HUFF Or COMPRESSION_ENGINE_MAXIMUM
    bCompCab = CabCompress(bBuf, COMPRESS_ALGORITHM_MSZIP)
    Debug.Print "Размер данных:  "; UBound(bBuf) + 1
    Debug.Print "NT-кмопрессия:  "; UBound(bCompNt) + 1
    Debug.Print "Cab-компрессия: "; UBound(bCompCab) + 1
    Debug.Print
End Sub