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

'---------------------------------------------------------------------------------------
' Procedure : ExtractToMemory
' DateTime  : 18-11-2006
' Author    : ArnoutV
' Purpose   :
'---------------------------------------------------------------------------------------
Public Function ExtractToMemory(ByVal sExtractFile As String, bData() As Byte) As Boolean
  Dim l As Long
  Dim FilePos As Long
  Dim sFilename As String
   
  If Len(ZLibVersion) = 0 Then
     Exit Function
  End If
   
  If CentralDirEndPos = 0 Then
    RaiseEvent ZipError(zeNoOpenZipFile, "There is no Zip File Open")
    Exit Function
  End If
   
  sExtractFile = LCase$(sExtractFile)
  
  If ReadCentralDirEnd(CentralDirEndPos) Then
    Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
    
    For l = 1 To CentralDirEnd.EntriesInTheCentralDir
      ReadCentralFileHeader sFilename
      If LCase$(GetFileName(sFilename)) = sExtractFile Then
        If CentralFileHeader.UnCompressedSize > 0 Then
          FilePos = Seek(m_fID)
          ExtractToMemory = ExtractArray(sFilename, bData)
        End If
        Exit For
      End If
    Next l
  End If
 
End Function

Option Explicit
Dim zip As New clsZipExtractionClass
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (arr() As Any) As Long
 
Private Sub Command1_Click()
    Dim strArray() As String
    Dim i As Long
    
    zip.OpenZip App.Path & "\test.zip"
    
    strArray() = zip.GetFiles ' Получить список файлов внутри ZIP
    
    For i = 0 To UBound(strArray)
        List1.AddItem strArray(i)
    Next
    
    List1.Selected(0) = True
    Label1.Caption = "Count files: " & zip.Count
    List1.SetFocus
    
    zip.CloseZip
End Sub
 
Private Sub List1_Click()
    Dim bytesData() As Byte
    
    zip.OpenZip App.Path & "\test.zip"
    zip.ExtractToMemory List1.Text, bytesData
    zip.CloseZip
    
    If SafeArrayGetDim(bytesData) > 0 Then Picture1.Picture = PictureFromBits(bytesData)
End Sub

Option Explicit
 
Private m_fID As Integer
Private m_bOpenZip As Boolean
 
 
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const OPEN_EXISTING  As Long = 3
Private Const FILE_SHARE_READ  As Long = &H1
Private Const FILE_SHARE_WRITE  As Long = &H2
Private Const GENERIC_WRITE  As Long = &H40000000
Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const MAX_PATH As Long = 260
 
 
Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
 
'Private Type SYSTEMTIME
'  Year As Integer
'  Month As Integer
'  DayOfWeek As Integer
'  Day As Integer
'  Hour As Integer
'  Minute As Integer
'  Second As Integer
'  Milliseconds As Integer
'End Type
 
Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type
 
 
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, src As Any, ByVal Length As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpBuffer As String, ByVal lpString As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
 
Private Declare Function ZLibVer Lib "zlibwapi.dll" Alias "zlibVersion" () As Long
'Private Declare Function Compress Lib "zlibwapi.dll" Alias "compress" (Dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
'Private Declare Function Compress2 Lib "zlibwapi.dll" Alias "compress2" (Dest As Any, destLen As Any, src As Any, ByVal srcLen As Long, ByVal Level As Long) As Long
Private Declare Function Uncompress Lib "zlibwapi.dll" Alias "uncompress" (Dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
Private Declare Function lCRC32 Lib "zlibwapi.dll" Alias "crc32" (ByVal crc As Long, Buffer As Any, ByVal Length As Long) As Long
 
Private Declare Function DosDateTimeToFileTime Lib "kernel32.dll" (ByVal wFatDate As Long, ByVal wFatTime As Long, lpFileTime As FILETIME) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32.dll" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
 
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long, CreationTime As FILETIME, LastAccessTime As FILETIME, LastWriteTime As FILETIME) As Long
 
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
 
                 
Public Enum eZipError
  zeZLibNotInstalled = 1
  zeNotZipFile = 2
  zeNoOpenZipFile = 3
  zeUnsupportedCompressionMethod = 4
  zeChecksumError = 5
  zeFileNotFound = 10
  zeFileAlreadyExists = 11
  zeCantRemoveFile = 12
  zeCantCreateFolder = 13
  zeCantCreateFile = 14
End Enum
 
Private Type typCentralFileHeader
  CentralFileHeaderSigniature As Long
  VersionMadeBy As Integer
  VersionNeededToExtract As Integer
  GeneralPurposeBitFlag As Integer
  CompressionMethod As Integer
  LastModFileTime As Integer
  LastModFileDate As Integer
  CRC32 As Long
  CompressedSize As Long
  UnCompressedSize As Long
  FileNameLength As Integer
  ExtraFieldLength As Integer
  FileCommentLength As Integer
  DiskNumberStart As Integer
  InternalFileAttributes As Integer
  ExternalFileAttributes As Long
  RelativeOffsetOfLocalHeader As Long
End Type
 
Private Type typCenteralDirEnd
  EndOFCentralDirSignature As Long
  NumberOfThisDisk As Integer
  NumberOfDiskWithCentralDir As Integer
  EntriesInTheCentralDirThisOnDisk As Integer
  EntriesInTheCentralDir As Integer
  SizeOfCentralDir As Long
  OffSetOfCentralDir As Long
  ZipFileCommentLength As Integer
End Type
 
Private Type typLocalFileHeader
  LocalFileHeaderSignature As Long
  VersionNeededToExtract As Integer
  GeneralPurposeBitFlag As Integer
  CompressionMethod As Integer
  LastModFileTime As Integer
  LastModFileDate As Integer
  CRC32 As Long
  CompressedSize As Long
  UnCompressedSize As Long
  FileNameLength As Integer
  ExtraFieldLength As Integer
End Type
 
Private Const EndOFCentralDirSignature As Long = &H6054B50
Private Const CentralFileHeaderSigniature As Long = &H2014B50
Private Const LocalFileHeaderSignature As Long = &H4034B50
 
Private CentralFileHeader As typCentralFileHeader
Private CentralDirEnd As typCenteralDirEnd
 
Private CentralDirEndPos As Long
 
Public Event Progress(Percent As Long, Cancel As Boolean)
Public Event Status(Text As String)
Public Event ZipError(Number As eZipError, Description As String)
 
Public Property Get ZLibVersion() As String
  On Error GoTo errHandler
  
  ZLibVersion = PointerToString(ZLibVer)
  Exit Property
 
errHandler:
   RaiseEvent ZipError(zeZLibNotInstalled, "Zlib is not installed")
End Property
 
Public Function OpenZip(ZipPath As String) As Boolean
 
  m_bOpenZip = False
  
  RaiseEvent Status("Opening Zip")
  CloseZip
 
  If Not FileExists(ZipPath) Then
    RaiseEvent ZipError(zeFileNotFound, "The file " & ZipPath & " doesn't exist")
    Exit Function
  End If
 
  m_fID = FreeFile
  Open ZipPath For Binary As #m_fID
  
  CentralDirEndPos = GetCentralDirEndPos(m_fID)
  If CentralDirEndPos > 0 Then
    m_bOpenZip = True
    OpenZip = True
    RaiseEvent Status("Zip Opened")
  Else
    RaiseEvent ZipError(zeNotZipFile, "The file " & ZipPath & " is not a Zip file")
  End If
   
End Function
 
Public Sub CloseZip()
  If m_fID <> 0 Then
     Close #m_fID
     m_fID = 0
     RaiseEvent Status("Zip Closed")
  End If
  CentralDirEndPos = 0
  
End Sub
 
Public Property Get Files() As Collection
  Dim l As Long
  Dim sFilename As String
  
  Set Files = New Collection
  
  If m_bOpenZip Then
    If ReadCentralDirEnd(CentralDirEndPos) Then
      
      Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
      For l = 1 To CentralDirEnd.EntriesInTheCentralDir
        ReadCentralFileHeader sFilename
        Files.Add sFilename, sFilename
      Next l
    End If
  End If
  
End Property
 
Public Function GetFiles() As String()
  Dim l As Long
  Dim sFilename As String
  Dim aTemp() As String
  
  If m_bOpenZip Then
    If ReadCentralDirEnd(CentralDirEndPos) Then
      ReDim aTemp(CentralDirEnd.EntriesInTheCentralDir - 1)
      
      Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
      For l = 1 To CentralDirEnd.EntriesInTheCentralDir
        ReadCentralFileHeader sFilename
        aTemp(l - 1) = sFilename
      Next l
    End If
  End If
  
  GetFiles = aTemp
End Function
 
Public Function Count() As Long
  If m_bOpenZip Then
    Count = CentralDirEnd.EntriesInTheCentralDir
  Else
    Count = -1
  End If
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : ExtractToMemory
' DateTime  : 18-11-2006
' Author    : ArnoutV
' Purpose   :
'---------------------------------------------------------------------------------------
Public Function ExtractToMemory(ByVal sExtractFile As String, bData() As Byte) As Boolean
  Dim l As Long
  Dim FilePos As Long
  Dim sFilename As String
   
  If Len(ZLibVersion) = 0 Then
     Exit Function
  End If
   
  If CentralDirEndPos = 0 Then
    RaiseEvent ZipError(zeNoOpenZipFile, "There is no Zip File Open")
    Exit Function
  End If
   
  sExtractFile = LCase$(sExtractFile)
  
  If ReadCentralDirEnd(CentralDirEndPos) Then
    Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
    
    For l = 1 To CentralDirEnd.EntriesInTheCentralDir
      ReadCentralFileHeader sFilename
      If LCase$(GetFileName(sFilename)) = sExtractFile Then
        If CentralFileHeader.UnCompressedSize > 0 Then
          FilePos = Seek(m_fID)
          ExtractToMemory = ExtractArray(sFilename, bData)
        End If
        Exit For
      End If
    Next l
  End If
 
End Function
 
Private Function GetFileName(Path As String) As String
  Dim l As Long
  
  l = InStrRev(Path, "\")
  If l > 0 Then GetFileName = Right$(Path, Len(Path) - l) Else GetFileName = Path
   
End Function
 
Private Function GetFilePath(Path As String) As String
 Dim l As Long
 
 l = InStrRev(Path, "\")
 If l > 0 Then GetFilePath = Left$(Path, l - 1)
   
End Function
 
Private Sub ReadCentralFileHeader(FileName As String)
  Dim ExtraField As String
  Dim Comment As String
  
  Get #m_fID, , CentralFileHeader
  If CentralFileHeader.CentralFileHeaderSigniature = CentralFileHeaderSigniature Then
    FileName = Space(CentralFileHeader.FileNameLength)
    Get #m_fID, , FileName
    FileName = Replace(FileName, "/", "\")
    ExtraField = Space(CentralFileHeader.ExtraFieldLength)
    Get #m_fID, , ExtraField
    Comment = Space(CentralFileHeader.FileCommentLength)
    Get #m_fID, , Comment
  End If
 
End Sub
 
Private Function ReadCentralDirEnd(Position As Long) As Boolean
  Dim ZipComment As String
  
  Get #m_fID, Position, CentralDirEnd
  ZipComment = Space(CentralDirEnd.ZipFileCommentLength)
  Get #m_fID, , ZipComment
  
  ReadCentralDirEnd = CentralDirEnd.NumberOfThisDisk = CentralDirEnd.NumberOfDiskWithCentralDir
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : ExtractArray
' DateTime  : 18-11-2006
' Author    : ArnoutV
' Purpose   :
'---------------------------------------------------------------------------------------
Private Function ExtractArray(Path As String, b() As Byte) As Boolean
  Dim LocalFileHeader As typLocalFileHeader
  Dim sFilename As String
  Dim sExtraField As String
 
  Get #m_fID, CentralFileHeader.RelativeOffsetOfLocalHeader + 1, LocalFileHeader
  If LocalFileHeader.LocalFileHeaderSignature = LocalFileHeaderSignature Then
    sFilename = Space(LocalFileHeader.FileNameLength)
    Get #m_fID, , sFilename
    sExtraField = Space(LocalFileHeader.ExtraFieldLength)
    Get #m_fID, , sExtraField
    ReDim b(LocalFileHeader.CompressedSize - 1)
    Get #m_fID, , b
    If CentralFileHeader.CompressionMethod = 0 Then
      'No Compression
      ExtractArray = True
    ElseIf CentralFileHeader.CompressionMethod = 8 Then 'Deflate Method
      If UnCompressBytes(b, LocalFileHeader.CompressedSize, LocalFileHeader.UnCompressedSize, LocalFileHeader.CRC32) Then
        ExtractArray = True
      Else
        RaiseEvent ZipError(zeChecksumError, "Data checksum error in " & Path)
      End If
    Else
      RaiseEvent ZipError(zeUnsupportedCompressionMethod, "The compression Method for " & sFilename & " is unsupported")
    End If
  End If
   
End Function
 
Private Function GetCentralDirEndPos(fID As Integer) As Long
 
  Dim bData() As Byte
  Dim l As Long
  Dim m As Long
 
  ReDim bData(LOF(fID) - 1)
  Get #fID, , bData
  
  For l = UBound(bData) - 3 To LBound(bData) Step -1
    CopyMemory m, bData(l), 4
    If m = EndOFCentralDirSignature Then
      GetCentralDirEndPos = l + 1
      Exit Function
    End If
  Next
 
End Function
 
Private Function UnCompressBytes(Buffer() As Byte, CompressedSize As Long, UnCompressedSize As Long, CRC32 As Long) As Boolean
   
  Dim b() As Byte
 
  Dim BufferSize As Long
  Dim FileSize As Long
  
  Dim DecompressCRC32 As Long
  Dim r As Long
 
  ReDim b(UBound(Buffer) + 2)
  
  'Zlib's Uncompress method expects the 2 byte head that the Compress method adds
  'so we put that on first. Luckily it's always the same value.
  b(0) = 120
  b(1) = 156
  CopyMemory b(2), Buffer(0), UBound(Buffer) + 1
 
  FileSize = UBound(Buffer) + 3
  BufferSize = CentralFileHeader.UnCompressedSize * 1.01 + 12
  ReDim Buffer(BufferSize - 1) As Byte
  
  r = Uncompress(Buffer(0), BufferSize, b(0), FileSize)
 
  ReDim Preserve Buffer(CentralFileHeader.UnCompressedSize - 1)
  DecompressCRC32 = lCRC32(0&, Buffer(0), UBound(Buffer) + 1)
  If DecompressCRC32 = CRC32 Then
    UnCompressBytes = True
  End If
 
End Function
 
Private Function PointerToString(Pointer As Long) As String
  Dim l As Long
  Dim s As String
  
  l = lstrlen(Pointer)
  s = Space(l)
  l = lstrcpy(s, Pointer)
  If l > 0 Then
     PointerToString = s
  End If
  
End Function
 
Private Function FileExists(sSource As String) As Boolean
 
  Dim WFD As WIN32_FIND_DATA
  Dim hFile As Long
  
  hFile = FindFirstFile(sSource, WFD)
  FileExists = hFile <> INVALID_HANDLE_VALUE
  
  Call FindClose(hFile)
   
End Function
 
Private Sub Class_Terminate()
  CloseZip
End Sub

'Returns decompressed buffer from Deflate compressed data
' - Buffer: compressed byte buffer
' - Position: buffer starting index (zero if not specified)
'             returns position after compressed data
Private Function Inflate(buffer() As Byte, Optional ByRef position As Long) As Byte()
    'Input/output buffer control
    Dim pBit As Long, oBuf() As Byte, oSize As Long, oByte As Long
    'Alphabets
    Dim hcLit(), hcDist(), hcCLen()
    'Alphabets upper bounds and counts
    Dim ubLen As Long, cLen As Long
    'Auxiliar variables
    Dim bFinal As Long, bType As Long, i As Long, lit As Long, dist As Long, length As Long, lens() As Integer
    
    pInit
    Do
        bFinal = pReadBits(buffer, position, pBit, 1)
        bType = pReadBits(buffer, position, pBit, 2)
        If bType = 0 Then
            'no compression
            'skip any remaining bits in current partially processed byte
            position = position - (pBit > 0)
            pBit = 0
            'read LEN
            length = buffer(position) + buffer(position + 1) * &H100&
            'check NLEN
            If (buffer(position + 2) + buffer(position + 3) * &H100& Xor &HFFFF&) <> length Then Err.Raise 57002, "Inflate", "Bad block data!"
            position = position + 4
            'Check input buffer
            If UBound(buffer) < position + length - 1 Then Err.Raise 57003, "Deflate.Inflate", "Not enough data!"
            If length Then 'Avoid unnecessary processing
                If oSize - oByte < length Then oSize = oByte + BUFFER_GROW_SIZE: ReDim Preserve oBuf(0 To oSize - 1)
                CopyMemory oBuf(oByte), buffer(position), length
                position = position + length
                oByte = oByte + length
            End If
        ElseIf bType = 3 Then
            Err.Raise 57001, "Deflate.Inflate", "Invalid block!"
        Else 'BType=1 or BType=2
            If bType = 1 Then
                'compressed with fixed Huffman codes
                hcLit = hcLitF
                hcDist = hcDistF
            ElseIf bType = 2 Then
                'compressed with dynamic Huffman codes
                cLen = pReadBits(buffer, position, pBit, 5) + 257 'count HLIT
                ubLen = pReadBits(buffer, position, pBit, 5) + cLen 'upper bound HLIT+HDIST
                length = pReadBits(buffer, position, pBit, 4) + 3 'upper bound HCLEN
                ReDim lens(0 To 18)
                For i = 0 To length
                    lens(hlCLen_map(i)) = pReadBits(buffer, position, pBit, 3)
                Next
                hcCLen = pHTBuild(lens, 18, 7)
                ReDim lens(0 To ubLen)
                length = 0
                i = 0
                Do While i <= ubLen
                    lit = pHTDecode(buffer, position, pBit, hcCLen)
                    If lit <= 15 Then
                        lens(i) = lit
                        If lens(i) > length Then length = lens(i)
                        i = i + 1
                    ElseIf lit = 16 Then
                        For i = i To i + pReadBits(buffer, position, pBit, 2) + 2
                            lens(i) = lens(i - 1)
                        Next
                    Else
                        i = i + pReadBits(buffer, position, pBit, 3 - 4 * (lit = 18)) + 3 - 8 * (lit = 18)
                    End If
                Loop
                hcLit = pHTBuild(lens, cLen - 1, length)
                hcDist = pHTBuild(lens, ubLen - cLen, length, cLen)
            End If
            Do
                lit = pHTDecode(buffer, position, pBit, hcLit)
                If lit < 256& Then
                    If oByte >= oSize Then oSize = oSize + BUFFER_GROW_SIZE: ReDim Preserve oBuf(0 To oSize)
                    oBuf(oByte) = lit
                    oByte = oByte + 1
                ElseIf lit > 256& Then
                    length = aLit_Add(lit)
                    If aLit_Bits(lit) Then length = length + pReadBits(buffer, position, pBit, aLit_Bits(lit))
                    dist = pHTDecode(buffer, position, pBit, hcDist)
                    If aDist_Bits(dist) Then
                        dist = aDist_Add(dist) + pReadBits(buffer, position, pBit, aDist_Bits(dist))
                    Else
                        dist = aDist_Add(dist)
                    End If
                    If oByte + length > oSize Then oSize = oSize + BUFFER_GROW_SIZE: ReDim Preserve oBuf(0 To oSize)
                    For oByte = oByte To oByte + length - 1
                        oBuf(oByte) = oBuf(oByte - dist)
                    Next
                End If
            Loop Until lit = 256&
        End If
    Loop Until bFinal
    position = position - (pBit > 0) 'Skip remaining bits
    If oByte Then ReDim Preserve oBuf(0 To oByte - 1) 'Trim output buffer
    Inflate = oBuf
End Function

'+++
Public Function CRC32(ByRef Data() As Byte) As Long
    Dim Remainder As Long
    Dim i As Long
    Dim j As Long
    
    If RunOnce = False Then 'Check if the table has already been generated.
        RunOnce = True
        For i = 0 To 255
            Remainder = i
            For j = 0 To 7
                If Remainder And 1 Then
                    Remainder = ShiftRight(Remainder) Xor &HEDB88320
                Else
                    Remainder = ShiftRight(Remainder)
                End If
            Next j
            Table(i) = Remainder
        Next i
        TableReady = True
    End If
    If TableReady = False Then Exit Function 'Check if table calculation has started, but not completed, on another thread.
    
    
    'Calculate CRC32 of data.
    CRC32 = &HFFFFFFFF
    For i = 0 To UBound(Data)
        CRC32 = ShiftRight8(CRC32) Xor Table((CRC32 And &HFF&) Xor Data(i))
    Next i
    CRC32 = Not CRC32
End Function
 
Private Function ShiftRight(ByVal Value As Long) As Long
    Dim TopBit As Boolean
    TopBit = Value And &H80000000
    ShiftRight = (Value And &H7FFFFFFF) \ 2
    If TopBit Then ShiftRight = ShiftRight Or &H40000000
End Function
 
Private Function ShiftRight8(ByVal Value As Long) As Long
    ShiftRight8 = ShiftRight(Value)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
End Function
'+++

Option Explicit
 
' Извините, я этот класс переделал на полный отказ от zlibwapi.dll использую только свой самописный код распаковки
' Накорябал этот код великий HackerVlad (посдирал код с разных мест и соединил воедино чтобы работало)
 
Private m_fID As Integer
Private m_bOpenZip As Boolean
 
 
Private Const INVALID_HANDLE_VALUE As Long = -1
Private Const OPEN_EXISTING  As Long = 3
Private Const FILE_SHARE_READ  As Long = &H1
Private Const FILE_SHARE_WRITE  As Long = &H2
Private Const GENERIC_WRITE  As Long = &H40000000
Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Private Const MAX_PATH As Long = 260
 
 
Private Type FILETIME
  dwLowDateTime As Long
  dwHighDateTime As Long
End Type
 
'Private Type SYSTEMTIME
'  Year As Integer
'  Month As Integer
'  DayOfWeek As Integer
'  Day As Integer
'  Hour As Integer
'  Minute As Integer
'  Second As Integer
'  Milliseconds As Integer
'End Type
 
Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type
 
 
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, src As Any, ByVal length As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpBuffer As String, ByVal lpString As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
 
'Private Declare Function ZLibVer Lib "zlibwapi.dll" Alias "zlibVersion" () As Long
'Private Declare Function Compress Lib "zlibwapi.dll" Alias "compress" (Dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
'Private Declare Function Compress2 Lib "zlibwapi.dll" Alias "compress2" (Dest As Any, destLen As Any, src As Any, ByVal srcLen As Long, ByVal Level As Long) As Long
'Private Declare Function Uncompress Lib "zlibwapi.dll" Alias "uncompress" (Dest As Any, destLen As Any, src As Any, ByVal srcLen As Long) As Long
'Private Declare Function lCRC32 Lib "zlibwapi.dll" Alias "crc32" (ByVal crc As Long, buffer As Any, ByVal length As Long) As Long
 
Private Declare Function DosDateTimeToFileTime Lib "kernel32.dll" (ByVal wFatDate As Long, ByVal wFatTime As Long, lpFileTime As FILETIME) As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32.dll" (lpLocalFileTime As FILETIME, lpFileTime As FILETIME) As Long
 
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long, CreationTime As FILETIME, LastAccessTime As FILETIME, LastWriteTime As FILETIME) As Long
 
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
 
                 
Public Enum eZipError
  zeZLibNotInstalled = 1
  zeNotZipFile = 2
  zeNoOpenZipFile = 3
  zeUnsupportedCompressionMethod = 4
  zeChecksumError = 5
  zeFileNotFound = 10
  zeFileAlreadyExists = 11
  zeCantRemoveFile = 12
  zeCantCreateFolder = 13
  zeCantCreateFile = 14
End Enum
 
Private Type typCentralFileHeader
  CentralFileHeaderSigniature As Long
  VersionMadeBy As Integer
  VersionNeededToExtract As Integer
  GeneralPurposeBitFlag As Integer
  CompressionMethod As Integer
  LastModFileTime As Integer
  LastModFileDate As Integer
  CRC32 As Long
  CompressedSize As Long
  UnCompressedSize As Long
  FileNameLength As Integer
  ExtraFieldLength As Integer
  FileCommentLength As Integer
  DiskNumberStart As Integer
  InternalFileAttributes As Integer
  ExternalFileAttributes As Long
  RelativeOffsetOfLocalHeader As Long
End Type
 
Private Type typCenteralDirEnd
  EndOFCentralDirSignature As Long
  NumberOfThisDisk As Integer
  NumberOfDiskWithCentralDir As Integer
  EntriesInTheCentralDirThisOnDisk As Integer
  EntriesInTheCentralDir As Integer
  SizeOfCentralDir As Long
  OffSetOfCentralDir As Long
  ZipFileCommentLength As Integer
End Type
 
Private Type typLocalFileHeader
  LocalFileHeaderSignature As Long
  VersionNeededToExtract As Integer
  GeneralPurposeBitFlag As Integer
  CompressionMethod As Integer
  LastModFileTime As Integer
  LastModFileDate As Integer
  CRC32 As Long
  CompressedSize As Long
  UnCompressedSize As Long
  FileNameLength As Integer
  ExtraFieldLength As Integer
End Type
 
Private Const EndOFCentralDirSignature As Long = &H6054B50
Private Const CentralFileHeaderSigniature As Long = &H2014B50
Private Const LocalFileHeaderSignature As Long = &H4034B50
 
Private CentralFileHeader As typCentralFileHeader
Private CentralDirEnd As typCenteralDirEnd
 
Private CentralDirEndPos As Long
 
Public Event Progress(Percent As Long, Cancel As Boolean)
Public Event Status(Text As String)
Public Event ZipError(Number As eZipError, Description As String)
 
'---
Private hlCLen_map(0 To 18) As Long, aLit_Bits(257 To 285) As Long, aLit_Add(257 To 285) As Long, aDist_Bits(0 To 29) As Long, aDist_Add(0 To 29) As Long
Private zhZero(1 To 15) '((0), (0,0), (0,0,0,0), ...)
Private hcLitF, hcDistF
Private z1BitMask(0 To 30) As Long '(&H01, &H02, &H04, &H08, &H10, &H20, &H40, &H80, ...
Private zBitsMask(0 To 30) As Long '(&H01, &H03, &H07, &H0F, &H1F, &H3F, &H7F, &HFF, ...
Private Const BUFFER_GROW_SIZE = 1048576 '1MB
'---
'+++
Dim Table(255) As Long
Dim RunOnce As Boolean
Dim TableReady As Boolean
'+++
 
Public Property Get ZLibVersion() As String
  On Error GoTo errHandler
  
  'ZLibVersion = PointerToString(ZLibVer)
  Exit Property
 
errHandler:
   RaiseEvent ZipError(zeZLibNotInstalled, "Zlib is not installed")
End Property
 
Public Function OpenZip(ZipPath As String) As Boolean
 
  m_bOpenZip = False
  
  RaiseEvent Status("Opening Zip")
  CloseZip
 
  If Not FileExists(ZipPath) Then
    RaiseEvent ZipError(zeFileNotFound, "The file " & ZipPath & " doesn't exist")
    Exit Function
  End If
 
  m_fID = FreeFile
  Open ZipPath For Binary As #m_fID
  
  CentralDirEndPos = GetCentralDirEndPos(m_fID)
  If CentralDirEndPos > 0 Then
    m_bOpenZip = True
    OpenZip = True
    RaiseEvent Status("Zip Opened")
  Else
    RaiseEvent ZipError(zeNotZipFile, "The file " & ZipPath & " is not a Zip file")
  End If
   
End Function
 
Public Sub CloseZip()
  If m_fID <> 0 Then
     Close #m_fID
     m_fID = 0
     RaiseEvent Status("Zip Closed")
  End If
  CentralDirEndPos = 0
  
End Sub
 
Public Property Get Files() As Collection
  Dim l As Long
  Dim sFilename As String
  
  Set Files = New Collection
  
  If m_bOpenZip Then
    If ReadCentralDirEnd(CentralDirEndPos) Then
      
      Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
      For l = 1 To CentralDirEnd.EntriesInTheCentralDir
        ReadCentralFileHeader sFilename
        Files.Add sFilename, sFilename
      Next l
    End If
  End If
  
End Property
 
Public Function GetFiles() As String()
  Dim l As Long
  Dim sFilename As String
  Dim aTemp() As String
  
  If m_bOpenZip Then
    If ReadCentralDirEnd(CentralDirEndPos) Then
      ReDim aTemp(CentralDirEnd.EntriesInTheCentralDir - 1)
      
      Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
      For l = 1 To CentralDirEnd.EntriesInTheCentralDir
        ReadCentralFileHeader sFilename
        aTemp(l - 1) = sFilename
      Next l
    End If
  End If
  
  GetFiles = aTemp
End Function
 
Public Function Count() As Long
  If m_bOpenZip Then
    Count = CentralDirEnd.EntriesInTheCentralDir
  Else
    Count = -1
  End If
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : ExtractToMemory
' DateTime  : 18-11-2006
' Author    : ArnoutV
' Purpose   :
'---------------------------------------------------------------------------------------
Public Function ExtractToMemory(ByVal sExtractFile As String, bData() As Byte) As Boolean
  Dim l As Long
  Dim FilePos As Long
  Dim sFilename As String
 
  'If Len(ZLibVersion) = 0 Then
  '   Exit Function
  'End If
  
  If CentralDirEndPos = 0 Then
    RaiseEvent ZipError(zeNoOpenZipFile, "There is no Zip File Open")
    Exit Function
  End If
 
  sExtractFile = LCase$(sExtractFile)
  
  If ReadCentralDirEnd(CentralDirEndPos) Then
    Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
    
    For l = 1 To CentralDirEnd.EntriesInTheCentralDir
      ReadCentralFileHeader sFilename
      If LCase$(GetFileName(sFilename)) = sExtractFile Then
        If CentralFileHeader.UnCompressedSize > 0 Then
          FilePos = Seek(m_fID)
          ExtractToMemory = ExtractArray(sFilename, bData)
        End If
        Exit For
      End If
    Next l
  End If
 
End Function
 
Private Function GetFileName(Path As String) As String
  Dim l As Long
  
  l = InStrRev(Path, "\")
  If l > 0 Then GetFileName = Right$(Path, Len(Path) - l) Else GetFileName = Path
   
End Function
 
Private Function GetFilePath(Path As String) As String
 Dim l As Long
 
 l = InStrRev(Path, "\")
 If l > 0 Then GetFilePath = Left$(Path, l - 1)
   
End Function
 
Private Sub ReadCentralFileHeader(FileName As String)
  Dim ExtraField As String
  Dim Comment As String
  
  Get #m_fID, , CentralFileHeader
  If CentralFileHeader.CentralFileHeaderSigniature = CentralFileHeaderSigniature Then
    FileName = Space(CentralFileHeader.FileNameLength)
    Get #m_fID, , FileName
    FileName = Replace(FileName, "/", "\")
    ExtraField = Space(CentralFileHeader.ExtraFieldLength)
    Get #m_fID, , ExtraField
    Comment = Space(CentralFileHeader.FileCommentLength)
    Get #m_fID, , Comment
  End If
 
End Sub
 
Private Function ReadCentralDirEnd(position As Long) As Boolean
  Dim ZipComment As String
  
  Get #m_fID, position, CentralDirEnd
  ZipComment = Space(CentralDirEnd.ZipFileCommentLength)
  Get #m_fID, , ZipComment
  
  ReadCentralDirEnd = CentralDirEnd.NumberOfThisDisk = CentralDirEnd.NumberOfDiskWithCentralDir
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : ExtractArray
' DateTime  : 18-11-2006
' Author    : ArnoutV
' Purpose   :
'---------------------------------------------------------------------------------------
Private Function ExtractArray(Path As String, b() As Byte) As Boolean
  Dim LocalFileHeader As typLocalFileHeader
  Dim sFilename As String
  Dim sExtraField As String
 
  Get #m_fID, CentralFileHeader.RelativeOffsetOfLocalHeader + 1, LocalFileHeader
  If LocalFileHeader.LocalFileHeaderSignature = LocalFileHeaderSignature Then
    sFilename = Space(LocalFileHeader.FileNameLength)
    Get #m_fID, , sFilename
    sExtraField = Space(LocalFileHeader.ExtraFieldLength)
    Get #m_fID, , sExtraField
    ReDim b(LocalFileHeader.CompressedSize - 1)
    Get #m_fID, , b
    If CentralFileHeader.CompressionMethod = 0 Then
      'No Compression
      ExtractArray = True
    ElseIf CentralFileHeader.CompressionMethod = 8 Then 'Deflate Method
      If UnCompressBytes(b, LocalFileHeader.CompressedSize, LocalFileHeader.UnCompressedSize, LocalFileHeader.CRC32) Then
        ExtractArray = True
      Else
        RaiseEvent ZipError(zeChecksumError, "Data checksum error in " & Path)
      End If
    Else
      RaiseEvent ZipError(zeUnsupportedCompressionMethod, "The compression Method for " & sFilename & " is unsupported")
    End If
  End If
   
End Function
 
Private Function GetCentralDirEndPos(fID As Integer) As Long
 
  Dim bData() As Byte
  Dim l As Long
  Dim m As Long
 
  ReDim bData(LOF(fID) - 1)
  Get #fID, , bData
  
  For l = UBound(bData) - 3 To LBound(bData) Step -1
    CopyMemory m, bData(l), 4
    If m = EndOFCentralDirSignature Then
      GetCentralDirEndPos = l + 1
      Exit Function
    End If
  Next
 
End Function
 
'---
Private Function pHTDecode(buffer, pByte As Long, pBit As Long, htCodes) As Integer
    Dim code As Long, l As Long
    For l = 1 To 15 'Max len possible
        code = code * 2 - ((buffer(pByte) And z1BitMask(pBit)) <> 0)
        pBit = (pBit + 1) And 7
        If pBit = 0 Then pByte = pByte + 1
        If htCodes(l)(code) Then pHTDecode = htCodes(l)(code) - 1: Exit Function
    Next
    Err.Raise 57004, "Deflate.Inflate", "Invalid data!"
End Function
 
Private Function pHTBuild(htLen, ByVal max_code As Long, ByVal max_len As Long, Optional ByVal Index As Long)
    Dim htCode(), bl_count(0 To 15) As Long, code As Long, next_code(0 To 15) As Long, i As Long
    For i = 0 To max_code
        bl_count(htLen(i + Index)) = bl_count(htLen(i + Index)) + 1
    Next
    bl_count(0) = 0
    For i = 1 To max_len
        code = (code + bl_count(i - 1)) * 2
        next_code(i) = code
    Next
    htCode = zhZero
    For i = 0 To max_code
        If htLen(i + Index) Then
            htCode(htLen(i + Index))(next_code(htLen(i + Index))) = i + 1
            next_code(htLen(i + Index)) = next_code(htLen(i + Index)) + 1
        End If
    Next
    pHTBuild = htCode
End Function
 
'Max bits read at once: 13 (Dist extra bits). Huffman decoding uses inline reading!
Private Function pReadBits(buffer, pByte As Long, pBit As Long, ByVal Size As Long) As Long
    Dim ret As Long
    'Read first byte:
    ret = buffer(pByte) \ z1BitMask(pBit)
    pBit = pBit + Size
    If pBit < 8 Then pReadBits = ret And zBitsMask(Size): Exit Function
    'Not enough, read second byte:
    Dim bw As Long 'bits written
    bw = 8 - pBit + Size
    pBit = Size - bw
    ret = (zBitsMask(pBit) And buffer(pByte + 1)) * z1BitMask(bw) + ret
    If pBit < 8 Then pByte = pByte + 1: pReadBits = ret: Exit Function
    'Not enough, read third and last byte:
    bw = bw + 8
    pBit = pBit - 8
    pByte = pByte + 2
    pReadBits = (zBitsMask(pBit) And buffer(pByte)) * z1BitMask(bw) + ret
End Function
 
Private Sub pInit()
    Dim i As Long, a_b() As String, a_a() As String, a16() As Integer
    If hlCLen_map(0) = 16 Then Exit Sub 'Still init'd
    
    'Tables:
    'Literal/Length alphabet extra bits
    a_b = Split("0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0")
    a_a = Split("3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258")
    For i = 257 To 285
        aLit_Bits(i) = a_b(i - 257)
        aLit_Add(i) = a_a(i - 257)
    Next
    'Distance alphabet extra bits
    a_b = Split("0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13")
    a_a = Split("1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577")
    For i = 0 To 29
        aDist_Bits(i) = a_b(i)
        aDist_Add(i) = a_a(i)
    Next
    'Code length read order
    a_a = Split("16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15")
    For i = 0 To 18
        hlCLen_map(i) = a_a(i)
    Next
    
    'Empty Huffman tree
    For i = 1 To 15
        ReDim a16(0 To 2 ^ i - 1)
        zhZero(i) = a16
    Next
    
    'Static Huffman tree
    hcLitF = zhZero
    hcDistF = zhZero
    For i = 0 To 143: hcLitF(8)(48 + i) = i + 1: Next
    For i = 144 To 255: hcLitF(9)(400 + i - 144) = i + 1: Next
    For i = 256 To 279: hcLitF(7)(i - 256) = i + 1: Next
    For i = 280 To 287: hcLitF(8)(192 + i - 280) = i + 1: Next
    For i = 0 To 29: hcDistF(5)(i) = i + 1: Next
    
    'Bit masks
    For i = 0 To 30
        z1BitMask(i) = 2 ^ i
        zBitsMask(i) = 2 ^ i - 1
    Next
 
End Sub
 
'Returns decompressed buffer from Deflate compressed data
' - Buffer: compressed byte buffer
' - Position: buffer starting index (zero if not specified)
'             returns position after compressed data
Private Function Inflate(buffer() As Byte, Optional ByRef position As Long) As Byte()
    'Input/output buffer control
    Dim pBit As Long, oBuf() As Byte, oSize As Long, oByte As Long
    'Alphabets
    Dim hcLit(), hcDist(), hcCLen()
    'Alphabets upper bounds and counts
    Dim ubLen As Long, cLen As Long
    'Auxiliar variables
    Dim bFinal As Long, bType As Long, i As Long, lit As Long, dist As Long, length As Long, lens() As Integer
    
    pInit
    Do
        bFinal = pReadBits(buffer, position, pBit, 1)
        bType = pReadBits(buffer, position, pBit, 2)
        If bType = 0 Then
            'no compression
            'skip any remaining bits in current partially processed byte
            position = position - (pBit > 0)
            pBit = 0
            'read LEN
            length = buffer(position) + buffer(position + 1) * &H100&
            'check NLEN
            If (buffer(position + 2) + buffer(position + 3) * &H100& Xor &HFFFF&) <> length Then Err.Raise 57002, "Inflate", "Bad block data!"
            position = position + 4
            'Check input buffer
            If UBound(buffer) < position + length - 1 Then Err.Raise 57003, "Deflate.Inflate", "Not enough data!"
            If length Then 'Avoid unnecessary processing
                If oSize - oByte < length Then oSize = oByte + BUFFER_GROW_SIZE: ReDim Preserve oBuf(0 To oSize - 1)
                CopyMemory oBuf(oByte), buffer(position), length
                position = position + length
                oByte = oByte + length
            End If
        ElseIf bType = 3 Then
            Err.Raise 57001, "Deflate.Inflate", "Invalid block!"
        Else 'BType=1 or BType=2
            If bType = 1 Then
                'compressed with fixed Huffman codes
                hcLit = hcLitF
                hcDist = hcDistF
            ElseIf bType = 2 Then
                'compressed with dynamic Huffman codes
                cLen = pReadBits(buffer, position, pBit, 5) + 257 'count HLIT
                ubLen = pReadBits(buffer, position, pBit, 5) + cLen 'upper bound HLIT+HDIST
                length = pReadBits(buffer, position, pBit, 4) + 3 'upper bound HCLEN
                ReDim lens(0 To 18)
                For i = 0 To length
                    lens(hlCLen_map(i)) = pReadBits(buffer, position, pBit, 3)
                Next
                hcCLen = pHTBuild(lens, 18, 7)
                ReDim lens(0 To ubLen)
                length = 0
                i = 0
                Do While i <= ubLen
                    lit = pHTDecode(buffer, position, pBit, hcCLen)
                    If lit <= 15 Then
                        lens(i) = lit
                        If lens(i) > length Then length = lens(i)
                        i = i + 1
                    ElseIf lit = 16 Then
                        For i = i To i + pReadBits(buffer, position, pBit, 2) + 2
                            lens(i) = lens(i - 1)
                        Next
                    Else
                        i = i + pReadBits(buffer, position, pBit, 3 - 4 * (lit = 18)) + 3 - 8 * (lit = 18)
                    End If
                Loop
                hcLit = pHTBuild(lens, cLen - 1, length)
                hcDist = pHTBuild(lens, ubLen - cLen, length, cLen)
            End If
            Do
                lit = pHTDecode(buffer, position, pBit, hcLit)
                If lit < 256& Then
                    If oByte >= oSize Then oSize = oSize + BUFFER_GROW_SIZE: ReDim Preserve oBuf(0 To oSize)
                    oBuf(oByte) = lit
                    oByte = oByte + 1
                ElseIf lit > 256& Then
                    length = aLit_Add(lit)
                    If aLit_Bits(lit) Then length = length + pReadBits(buffer, position, pBit, aLit_Bits(lit))
                    dist = pHTDecode(buffer, position, pBit, hcDist)
                    If aDist_Bits(dist) Then
                        dist = aDist_Add(dist) + pReadBits(buffer, position, pBit, aDist_Bits(dist))
                    Else
                        dist = aDist_Add(dist)
                    End If
                    If oByte + length > oSize Then oSize = oSize + BUFFER_GROW_SIZE: ReDim Preserve oBuf(0 To oSize)
                    For oByte = oByte To oByte + length - 1
                        oBuf(oByte) = oBuf(oByte - dist)
                    Next
                End If
            Loop Until lit = 256&
        End If
    Loop Until bFinal
    position = position - (pBit > 0) 'Skip remaining bits
    If oByte Then ReDim Preserve oBuf(0 To oByte - 1) 'Trim output buffer
    Inflate = oBuf
End Function
'---
 
'+++
Public Function CRC32(ByRef Data() As Byte) As Long
    Dim Remainder As Long
    Dim i As Long
    Dim j As Long
    
    If RunOnce = False Then 'Check if the table has already been generated.
        RunOnce = True
        For i = 0 To 255
            Remainder = i
            For j = 0 To 7
                If Remainder And 1 Then
                    Remainder = ShiftRight(Remainder) Xor &HEDB88320
                Else
                    Remainder = ShiftRight(Remainder)
                End If
            Next j
            Table(i) = Remainder
        Next i
        TableReady = True
    End If
    If TableReady = False Then Exit Function 'Check if table calculation has started, but not completed, on another thread.
    
    
    'Calculate CRC32 of data.
    CRC32 = &HFFFFFFFF
    For i = 0 To UBound(Data)
        CRC32 = ShiftRight8(CRC32) Xor Table((CRC32 And &HFF&) Xor Data(i))
    Next i
    CRC32 = Not CRC32
End Function
 
Private Function ShiftRight(ByVal Value As Long) As Long
    Dim TopBit As Boolean
    TopBit = Value And &H80000000
    ShiftRight = (Value And &H7FFFFFFF) \ 2
    If TopBit Then ShiftRight = ShiftRight Or &H40000000
End Function
 
Private Function ShiftRight8(ByVal Value As Long) As Long
    ShiftRight8 = ShiftRight(Value)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
    ShiftRight8 = ShiftRight(ShiftRight8)
End Function
'+++
 
Private Function UnCompressBytes(buffer() As Byte, CompressedSize As Long, UnCompressedSize As Long, getCRC32 As Long) As Boolean
   
  Dim b() As Byte
  Dim b2() As Byte
 
  Dim BufferSize As Long
  Dim FileSize As Long
  
  Dim DecompressCRC32 As Long
  Dim r As Long
 
 
 
  ReDim b(UBound(buffer) + 2)
  
  'Zlib's Uncompress method expects the 2 byte head that the Compress method adds
  'so we put that on first. Luckily it's always the same value.
  b(0) = 120
  b(1) = 156
  CopyMemory b(2), buffer(0), UBound(buffer) + 1
 
  FileSize = UBound(buffer) + 3
  BufferSize = CentralFileHeader.UnCompressedSize * 1.01 + 12
  'ReDim buffer(BufferSize - 1) As Byte
  
   
  'r = Uncompress(buffer(0), BufferSize, b(0), FileSize)
  
  b2 = Inflate(buffer)
  buffer = b2
    
  ReDim Preserve buffer(CentralFileHeader.UnCompressedSize - 1)
  
  'DecompressCRC32 = lCRC32(0&, buffer(0), UBound(buffer) + 1)
  DecompressCRC32 = CRC32(buffer)
  
  If DecompressCRC32 = getCRC32 Then
    UnCompressBytes = True
  End If
 
End Function
 
Private Function PointerToString(Pointer As Long) As String
  Dim l As Long
  Dim s As String
  
  l = lstrlen(Pointer)
  s = Space(l)
  l = lstrcpy(s, Pointer)
  If l > 0 Then
     PointerToString = s
  End If
  
End Function
 
Private Function FileExists(sSource As String) As Boolean
 
  Dim WFD As WIN32_FIND_DATA
  Dim hFile As Long
  
  hFile = FindFirstFile(sSource, WFD)
  FileExists = hFile <> INVALID_HANDLE_VALUE
  
  Call FindClose(hFile)
   
End Function
 
Private Sub Class_Terminate()
  CloseZip
End Sub

Option Explicit
Dim zip As New clsZipExtractionClass
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (arr() As Any) As Long
 
Private Sub Command1_Click()
    Dim strArray() As String
    Dim i As Long
    
    zip.OpenZip App.Path & "\test.zip"
    
    strArray() = zip.GetFiles ' Get a list files inside a ZIP
    
    If SafeArrayGetDim(strArray) > 0 Then
        For i = 0 To UBound(strArray)
            List1.AddItem strArray(i)
        Next
        
        List1.Selected(0) = True
        Label1.Caption = "Count files: " & zip.Count
        List1.SetFocus
    End If
    
    zip.CloseZip
End Sub
 
Private Sub List1_Click()
    Dim bytesData() As Byte
    
    zip.OpenZip App.Path & "\test.zip"
    zip.ExtractToMemory List1.Text, bytesData
    zip.CloseZip
    
    If SafeArrayGetDim(bytesData) > 0 Then Picture1.Picture = PictureFromBits(bytesData)
End Sub

Private Declare Function RtlComputeCrc32 Lib "ntdll.dll" ( _
     ByVal dwInitial As Long, _
     ByVal pData As Long, _
     ByVal iLen As Long) As Long
 
Public Function Crc32Api ( tBuff() As Byte) as long    
    Crc32Api = RtlComputeCrc32(0, VarPtr(tBuff(0)), UBound(tBuff) + 1)
End Function