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

Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
 
Private WithEvents m_oZip As cZipArchive
Private WithEvents m_oExtractInMemory As cZipArchive
 
Private Sub Command1_Click()
    Dim i As Long
    
    If List1.ListCount > 0 Then List1.Clear
    
    With m_oZip
        .OpenArchive App.Path & "\test.zip"
        
        For i = 0 To .FileCount - 1
            List1.AddItem .FileInfo(i, zipIdxFileName) & "    " & .FileInfo(i, zipIdxSize) & " bytes"
        Next
        
        Label1.Caption = "Count files: " & .FileCount
    End With
    
    List1.Selected(0) = True
    List1.SetFocus
End Sub
 
Private Sub List1_Click()
    Dim bytesData() As Byte
    Dim tick As Long
    
    tick = GetTickCount
    
    If m_oZip.Extract(bytesData, List1.ListIndex) = True Then
        Label2.Caption = "ml: " & GetTickCount - tick
        Picture1.Picture = PictureFromBits(bytesData)
    End If
End Sub
 
Private Sub Form_Load()
    Set m_oZip = New cZipArchive
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    Set m_oZip = Nothing
End Sub

Option Explicit
'OldName:clsZipExtractionClass
'by xiaoyao / HackerVlad
 
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp" (ByVal PathName As String) As Long
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
'    FileName As Long              'ОДјюГы
'    ExtraField As Long            'ёЅјУРЕПў
'    Comment As Long               'ОДјюёЅЧў
End Type
 
'EndOfCentralDirectory
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:
MsgBox "Zlib is not installed"
   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
        
        'Seek #m_fID, LenB(CentralDirEnd)
      Next l
    End If
  End If
  
End Property
 
'---------------------------------------------------------------------------------------
' Procedure : ExtractToFolder
' DateTime  : 2024-10-31
' Author    : xiaoyao (china)
'---------------------------------------------------------------------------------------
Public Function ExtractToFolder(ToFolder As String, Optional ByVal FolderOrFile As String = "*", Optional ByRef SaveFileCount As Long) As Boolean
'FolderOrFile=1.jpg or folder1\2.jpg or *.pdf
'FolderOrFile= folder1\*  (Extract path:folder1\)
'FolderOrFile="*", Extract all Folder and Files
  Dim l As Long
  Dim FilePos As Long
  Dim sFilename As String, bData() As Byte
   
  If Len(ZLibVersion) = 0 Then
     Exit Function
  End If
  Dim DiskFile As String, FilePath As String
  If CentralDirEndPos = 0 Then
    RaiseEvent ZipError(zeNoOpenZipFile, "There is no Zip File Open")
    Exit Function
  End If
   
  FolderOrFile = LCase$(FolderOrFile)
  Dim iseek As Long
     
  Dim ToMemoryOK As Boolean
  If ReadCentralDirEnd(CentralDirEndPos) Then
    Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
    
    For l = 1 To CentralDirEnd.EntriesInTheCentralDir
      ReadCentralFileHeader sFilename
      sFilename = LCase(Replace(sFilename, "/", "\"))
      If sFilename Like FolderOrFile Then
         DiskFile = ToFolder & sFilename
      'If LCase$(GetFileName(sFilename)) = FolderOrFile Then
        If Right(sFilename, 1) = "\" Then        'IS FOLDER
            MakeLongDir DiskFile
        Else
            FilePos = Seek(m_fID)
            'Debug.Print sFilename & ",FileSizeЈє" & CentralFileHeader.UnCompressedSize
            If CentralFileHeader.UnCompressedSize > 0 Then
                
                ToMemoryOK = ExtractArray(sFilename, bData)
              Else
              ReDim bData(-1 To -1)
            End If
               
                FilePath = Left(DiskFile, InStr(DiskFile, "\"))
                MakeLongDir FilePath
                PutToFileBin DiskFile, bData
                SaveFileCount = SaveFileCount + 1
                'RE SET FILE Pointer For Read Next Zip FileInfo
                Seek #m_fID, FilePos
        End If
        
      End If
    Next l
  End If
End Function
Function PutToFileBin(filename As String, bin() As Byte) As Boolean
   '[mycode_id:1940],edittime:2011/7/12 0:04:11
   On Error Resume Next
   Kill filename
   On Error GoTo Err
       Dim hFile As Integer
       hFile = FreeFile
       Open filename For Binary As #hFile
       Put #hFile, , bin
       Close #hFile
       PutToFileBin = True
   Exit Function
Err:
       MsgBox Err.Description
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
      sFilename = LCase(Replace(sFilename, "/", "\"))
      If sFilename = sExtractFile Then
      'If LCase$(GetFileName(sFilename)) = sExtractFile Then
        If CentralFileHeader.UnCompressedSize > 0 Then
          FilePos = Seek(m_fID)
          ExtractToMemory = ExtractArray(sFilename, bData)
          Else
          ReDim bData(-1 To -1)
        End If
        Exit For
      End If
    Next l
  End If
End Function
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 GetFilesFixed() As String()
''MsgBox "err:"
'
'  Dim aTemp() As String
'
'  Dim I 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")
'    ReDim aTemp(-1 To -1)
'     GetFilesFixed = aTemp
'    Exit Function
'  End If
'
'
'
'  If ReadCentralDirEnd(CentralDirEndPos) Then
'    ReDim aTemp(CentralDirEnd.EntriesInTheCentralDir - 1)
'
'    Seek #m_fID, CentralDirEnd.OffSetOfCentralDir + 1
'    For I = 1 To CentralDirEnd.EntriesInTheCentralDir
'
'      ReadCentralFileHeader sFilename
'       aTemp(I - 1) = sFilename
'
'        ' Seek #m_fID, CentralDirEnd.OffSetOfCentralDir
'    Next I
'  End If
'  GetFilesFixed = aTemp
'End Function
 
'    Dim iseek As Long
'    iseek = VBA.Seek(m_fID)
'    Debug.Print "iseek=" & iseek
    
Private Sub ReadCentralFileHeader(filename As String)
  Dim ExtraField As String
  Dim Comment As String
   Dim iseek As Long
  filename = ""
  iseek = VBA.Seek(m_fID)
  'Debug.Print "РВЅЪµДО»ЦГЈєiseek=" & iseek
  Get #m_fID, , CentralFileHeader
  
  If CentralFileHeader.CentralFileHeaderSigniature = CentralFileHeaderSigniature Then
    
    filename = ReadStrByLen(CentralFileHeader.FileNameLength)
    filename = Replace(filename, "/", "\")
    
 
      iseek = iseek + Len(CentralFileHeader) + CentralFileHeader.FileNameLength + CentralFileHeader.ExtraFieldLength + CentralFileHeader.FileCommentLength
     Seek m_fID, iseek
     'Debug.Print "Т»ёцОДјюРЕПўМбИЎНкіЙЈ¬МшµЅЈє" & LastSeek
    'ExtraField = ReadStrByLen(CentralFileHeader.ExtraFieldLength)
    'Comment = ReadStrByLen(CentralFileHeader.FileCommentLength)
'  FileName = PointerToString2(CentralFileHeader.FileName, CentralFileHeader.FileNameLength)
'  ExtraField = PointerToString2(CentralFileHeader.ExtraField, CentralFileHeader.ExtraFieldLength)
'  Comment = PointerToString2(CentralFileHeader.Comment, CentralFileHeader.FileCommentLength)
 
'    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
Else
 
  End If
 
End Sub
 
Public Function Count() As Long
  If m_bOpenZip Then
    Count = CentralDirEnd.EntriesInTheCentralDir
  Else
    Count = -1
  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
 
 
Function ReadStrByLen(Len1 As Integer) As String
 Dim Buffer() As Byte
 If Len1 = 0 Then Exit Function
  ReDim Buffer(Len1 - 1)
  Get #m_fID, , Buffer
  ReadStrByLen = StrConv(Buffer, vbUnicode)
End Function
 
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
  'ExtractArray NowFile
  Dim LocalFileHeader As typLocalFileHeader
  Dim sFilename As String
  Dim sExtraField As String
 
  Get #m_fID, CentralFileHeader.RelativeOffsetOfLocalHeader + 1, LocalFileHeader
  If LocalFileHeader.LocalFileHeaderSignature = LocalFileHeaderSignature Then
    Dim iseek As Long
     iseek = VBA.Seek(m_fID)
'    sFilename = Space(LocalFileHeader.FileNameLength)
'    Get #m_fID, , sFilename
'    sExtraField = Space(LocalFileHeader.ExtraFieldLength)
'    Get #m_fID, , sExtraField
    
    Seek #m_fID, iseek + LocalFileHeader.FileNameLength + LocalFileHeader.ExtraFieldLength
    
 
    iseek = VBA.Seek(m_fID)
    Debug.Print "iseek=" & iseek
 
    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
Function MakeLongDir(ByVal PathToDest As String) As Boolean
    'ЅЁБў¶ај¶ЧУДїБй
    Dim R As Long
    PathToDest = Replace(PathToDest, "/", "\")
    If Right(PathToDest, 1) <> "\" Then PathToDest = PathToDest & "\"
    MakeLongDir = MakeSureDirectoryPathExists(PathToDest)
End Function

Option Explicit
'==========
'MiniZipDir version 2
'==========
'
'Minimal interface to minilib (in zlibwapi.dll) for querying the directory in a Zip archive.
'This returns the item's Name and CRC as stored in the Zip archive.
'
'Put zlibwapi.dll into the Project's (EXE's) folder.
'
'NOTES
'
'   o Paths to Zip files to be queried must be absolute, full-qualified paths.  It doesn't
'     find them if you try to look up by relative path.
'
'   o The String values in and out are in theory ANSI but may well actually be codepage 437
'     DOS OEM extended ASCII.  However a lot of Zip archive creation software probably just
'     jams ANSI in there under the current codepage.
'
'     In theory there is also UTF-8 support but that probably is only true for leter versions
'     of the Zip format.  Or perhaps only for Zip64 format?
'
'   o Directory separators come back as "/" and not "\" but we could easily replace those
'     here.  I'm not sure why they do this though.  I had assumed Zip format originated on
'     MS-DOS, but true or not perhaps "/" was put in back then to be universal, or perhaps
'     this is something that "minilib" is doing?
'
 
Private Const WIN32_NULL As Long = 0
 
Private Const MAX_PATH As Long = 260
 
Private Const Z_ERRNO As Long = -1
 
Private Const UNZ_NULL As Long = 0
 
Public Enum UnzipResults
    UNZ_OK = 0
    UNZ_END_OF_LIST_OF_FILE = -100
    UNZ_ERRNO = Z_ERRNO
    UNZ_EOF = 0
    UNZ_PARAMERROR = -102
    UNZ_BADZIPFILE = -103
    UNZ_INTERNALERROR = -104
    UNZ_CRCERROR = -105
    UNZ_ALREADYOPEN = -500 'Private extension.
    UNZ_OPENFAILED = -501 'Private extension.
    UNZ_NOTOPEN = -502 'Private extension.
End Enum
#If False Then
Dim UNZ_OK, UNZ_END_OF_LIST_OF_FILE, UNZ_ERRNO, UNZ_EOF, UNZ_PARAMERROR, UNZ_BADZIPFILE
Dim UNZ_INTERNALERROR, UNZ_CRCERROR, UNZ_ALREADYOPEN
#End If
 
Private Type tm_unz
    tm_sec As Long                  'seconds after the minute - [0,59]
    tm_min As Long                  'minutes after the hour - [0,59]
    tm_hour As Long                 'hours since midnight - [0,23]
    tm_mday As Long                 'day of the month - [1,31]
    tm_mon As Long                  'months since January - [0,11]
    tm_year As Long                 'years - [1980..2044]
End Type
 
Private Type unz_file_info
    version As Long                 'version made by                 2 bytes
    version_needed As Long          'version needed to extract       2 bytes
    flag As Long                    'general purpose bit flag        2 bytes
    compression_method As Long      'compression method              2 bytes
    dosDate As Long                 'last mod file date in Dos fmt   4 bytes
    Crc As Long                     'crc-32                          4 bytes
    compressed_size As Long         'compressed size                 4 bytes
    uncompressed_size As Long       'uncompressed size               4 bytes
    size_filename As Long           'filename length                 2 bytes
    size_file_extra As Long         'extra field length              2 bytes
    size_file_comment As Long       'file comment length             2 bytes
    disk_num_start As Long          'disk number start               2 bytes
    internal_fa As Long             'internal file attributes        2 bytes
    external_fa As Long             'external file attributes        4 bytes
    tmu_date As tm_unz
End Type
 
Private Declare Function unzOpen Lib "zlibwapi" ( _
    ByVal Path As String) As Long
Private Declare Function unzClose Lib "zlibwapi" ( _
    ByVal unzhFile As Long) As UnzipResults
Private Declare Function unzGoToFirstFile Lib "zlibwapi" ( _
    ByVal unzhFile As Long) As UnzipResults
Private Declare Function unzGoToNextFile Lib "zlibwapi" ( _
    ByVal unzhFile As Long) As UnzipResults
Private Declare Function unzReadCurrentFile Lib "zlibwapi" ( _
    ByVal unzhFile As Long, ByVal BufferPtr As Long, ByVal Size As Long) As UnzipResults
Private Declare Function unzOpenCurrentFile Lib "zlibwapi.dll" (ByVal unzhFile As Long) As Long
Private Declare Function unzCloseCurrentFile Lib "zlibwapi.dll" (ByVal unzhFile As Long) As Long
 
Private Declare Function unzGetCurrentFileInfo Lib "zlibwapi" ( _
    ByVal unzhFile As Long, _
    ByVal pFileInfo As Long, _
    ByVal FileName As String, _
    ByVal FileNameBufferSize As Long, _
    ByVal pExtraField As Long, _
    ByVal ExtraFieldBufferSize As Long, _
    ByVal Comment As String, _
    ByVal CommentBufferSize As Long) As UnzipResults
 
Private unzhFile As Long 'Unzip handle to an open archive.
 
Private mEndOfFiles As Boolean
Private mUnzResults As UnzipResults
 
Public Property Get EndOfFiles() As Boolean
    EndOfFiles = mEndOfFiles
End Property
 
Public Property Get UnzResults() As UnzipResults
    UnzResults = mUnzResults
End Property
Function FindFile(ByVal zipChildFileName As String, Optional FileSize As Long, Optional Crc As Long) As Boolean
    'Exists(ChildFile) 'by xiaoyao #abcd
    Dim Ret As UnzipResults, FindFileOK As Boolean
    zipChildFileName = LCase(zipChildFileName)
    zipChildFileName = Replace(zipChildFileName, "\", "/")
    If unzhFile = UNZ_NULL Then
        mUnzResults = UNZ_NOTOPEN
        Err.Raise &H80045508, TypeName(Me), "Not open"
    End If
    Dim FileName As String
        Ret = unzGoToFirstFile(unzhFile)
    Do While Ret = UNZ_OK
        GetCurrentFileInfo FileName, Crc, FileSize
        If zipChildFileName = LCase(FileName) Then
            FindFile = True
            Exit Do
        End If
        Ret = unzGoToNextFile(unzhFile)
    Loop
End Function
Function ReadFileByte(ByVal zipChildFileName As String, Buffer() As Byte) As Boolean
 'by xiaoyao #abcd
    Dim Ret As UnzipResults, FileSize As Long
    If FindFile(zipChildFileName, FileSize) Then
        ReadFileByte = True
        If FileSize > 0 Then
            FileSize = FileSize
            ReDim Buffer(FileSize - 1)
            Ret = unzOpenCurrentFile(unzhFile)
            If Ret = UNZ_OK Then 'BufferPtr
                Ret = unzReadCurrentFile(unzhFile, VarPtr(Buffer(0)), FileSize) 'Result is FileByte
                If Ret <> FileSize Then
                    If Ret > 0 Then
                        ReDim Preserve Buffer(Ret - 1)
                    Else
                        ReDim Buffer(-1 To -1)
                    End If
                End If
                
            End If
            
             unzCloseCurrentFile unzhFile
        Else
            ReDim Buffer(-1 To -1)
        End If
        
    End If
End Function
Function UnzipAll(Folder As String) As Boolean 'by xiaoyao #abcd
    'unzip all file to a folder
    MsgBox "please add code"
End Function
Function UnzipChildFolder(Folder As String) As Boolean 'by xiaoyao #abcd
    'unzip a Child Folder from zip a Disk folder
    MsgBox "please add code"
End Function
Function UnzipToFile(ByVal zipChildFileName As String) As Boolean
 'by xiaoyao #abcd
    Dim Ret As Long, Buffer() As Byte
    If ReadFileByte(zipChildFileName, Buffer) Then
        UnzipToFile = PutToFileBin(zipChildFileName, Buffer)
    End If
End Function
 
Function PutToFileBin(FileName As String, bin() As Byte) As Boolean
   '[mycode_id:1940],edittime:2011/7/12 0:04:11
   On Error Resume Next
   Kill FileName
   On Error GoTo Err
       Dim hFile As Integer
       hFile = FreeFile
       Open FileName For Binary As #hFile
       Put #hFile, , bin
       Close #hFile
       PutToFileBin = True
   Exit Function
Err:
       MsgBox Err.Description
End Function
 
Sub GetFileList(FileList() As String, FileSizeArr() As Long, CrcArr() As Long)
 'by xiaoyao #abcd
    Dim Crc As Long
    Dim Path As String, FileSize As Long
    Dim Listc As New Dictionary
    Dim CrcDc As New Dictionary
    Dim FindFileOK As Boolean
    FindFileOK = ListFile(Path, Crc, FileSize, FindFileOK)
    Do While FindFileOK
        Listc.Add Path, FileSize
        CrcDc.Add Path, Crc
        FindFileOK = ListFile(Path, Crc, FileSize, FindFileOK)
    Loop
'    FirstFile Path, crc
'    Do While Len(Path)
'        Listc.Add Path
'        NextFile Path, crc
'    Loop
Dim ub As Long, I As Long
    ub = Listc.Count - 1
    If ub > -1 Then
        ReDim FileList(ub)
        ReDim FileSizeArr(ub)
        ReDim CrcArr(ub)
        Dim v
        With Listc
        For I = 0 To ub
            FileList(I) = .Keys(I)
            FileSizeArr(I) = .Items(I)
            CrcArr(I) = CrcDc.Items(I)
        Next
        End With
    Else
        ReDim FileSizeArr(-1 To -1)
        ReDim FileList(-1 To -1)
        ReDim CrcArr(-1 To -1)
    End If
End Sub
Public Sub CloseZip()
    Dim NewUnzResults As UnzipResults
 
    If unzhFile <> UNZ_NULL Then
        NewUnzResults = unzClose(unzhFile)
        If NewUnzResults <> UNZ_OK Then
            mUnzResults = NewUnzResults
            Err.Raise &H80045500, TypeName(Me), "Close failed"
        Else
            mUnzResults = UNZ_OK
            unzhFile = UNZ_NULL
            mEndOfFiles = True
        End If
    Else
        'Wasn't open, just quietly return:
        mUnzResults = UNZ_OK
    End If
End Sub
Public Function ListFile(ByRef Name As String, ByRef Crc As Long, ByRef FileSize As Long, Optional NextFile As Boolean) As Boolean
'abcd,xiaoyao
    Dim NewUnzResults As UnzipResults
 
    If unzhFile = UNZ_NULL Then
        mUnzResults = UNZ_NOTOPEN
        Err.Raise &H80045508, TypeName(Me), "Not open"
    End If
    If NextFile Then
        NewUnzResults = unzGoToNextFile(unzhFile)
    Else
        NewUnzResults = unzGoToFirstFile(unzhFile)
    End If
    If NewUnzResults = UNZ_END_OF_LIST_OF_FILE Then
        Name = vbNullString
        mEndOfFiles = True
    ElseIf NewUnzResults = UNZ_OK Then
        mUnzResults = UNZ_OK
        GetCurrentFileInfo Name, Crc, FileSize
        ListFile = True
    Else
        mUnzResults = NewUnzResults
        Err.Raise &H8004550C, TypeName(Me), "FirstFile failed"
    End If
End Function
Public Sub FirstFile(ByRef Name As String, ByRef Crc As Long)
    Dim NewUnzResults As UnzipResults
 
    If unzhFile = UNZ_NULL Then
        mUnzResults = UNZ_NOTOPEN
        Err.Raise &H80045508, TypeName(Me), "Not open"
    End If
 
    NewUnzResults = unzGoToFirstFile(unzhFile)
    If NewUnzResults = UNZ_END_OF_LIST_OF_FILE Then
        Name = vbNullString
        mEndOfFiles = True
    ElseIf NewUnzResults = UNZ_OK Then
        mUnzResults = UNZ_OK
        GetCurrentFileInfo Name, Crc
    Else
        mUnzResults = NewUnzResults
        Err.Raise &H8004550C, TypeName(Me), "FirstFile failed"
    End If
End Sub
 
Public Sub NextFile(ByRef Name As String, ByRef Crc As Long)
    Dim NewUnzResults As UnzipResults
 
    If unzhFile = UNZ_NULL Then
        mUnzResults = UNZ_NOTOPEN
        Err.Raise &H80045510, TypeName(Me), "Not open"
    End If
 
    NewUnzResults = unzGoToNextFile(unzhFile)
    If NewUnzResults = UNZ_END_OF_LIST_OF_FILE Then
        Name = vbNullString
        mEndOfFiles = True
    ElseIf NewUnzResults = UNZ_OK Then
        mUnzResults = UNZ_OK
        GetCurrentFileInfo Name, Crc
    Else
        mUnzResults = NewUnzResults
        Err.Raise &H80045514, TypeName(Me), "NextFile failed"
    End If
End Sub
 
Public Sub OpenZip(ByRef Path As String)
    Dim NewUnzhFile As Long
 
    If unzhFile <> UNZ_NULL Then
        mUnzResults = UNZ_ALREADYOPEN
        Err.Raise &H80045520, TypeName(Me), "Already open"
    End If
 
    NewUnzhFile = unzOpen(Path)
    If NewUnzhFile = UNZ_NULL Then
        mUnzResults = UNZ_OPENFAILED
        Err.Raise &H80045524, TypeName(Me), "Open failed"
    Else
        mUnzResults = UNZ_OK
        unzhFile = NewUnzhFile
    End If
End Sub
 
Private Sub GetCurrentFileInfo(ByRef Name As String, ByRef Crc As Long, Optional ByRef FileSize As Long)
'ABCD,ИЎОДјюРЕПў
    Dim Buffer As String
    Dim unz_file_info As unz_file_info
    Dim NewUnzResults As UnzipResults
    Dim EndPos As Long
 
    Buffer = Space$(MAX_PATH - 1)
    NewUnzResults = unzGetCurrentFileInfo(unzhFile, _
                                          VarPtr(unz_file_info), _
                                          Buffer, _
                                          MAX_PATH, _
                                          WIN32_NULL, _
                                          0, _
                                           vbNullString, _
                                          0)
    If NewUnzResults <> UNZ_OK Then
        mUnzResults = NewUnzResults
        Err.Raise &H80045504, TypeName(Me), "GetCurrentFileInfo failed"
    Else
        FileSize = unz_file_info.uncompressed_size
        EndPos = InStr(Buffer, vbNullChar)
        If EndPos = 0 Then
            Name = Buffer
        Else
            Name = Left$(Buffer, EndPos - 1)
        End If
        Crc = unz_file_info.Crc
    End If
End Sub
 
Private Sub Class_Initialize()
    mEndOfFiles = True
End Sub
 
Private Sub Class_Terminate()
    If unzhFile <> UNZ_NULL Then CloseZip
End Sub

Option Explicit
Dim Zip As New MiniZipDir2
 
Private Sub Command1_Click()
Dim SZ
SZ = Split(List1, Chr(9))
Dim Sarr() As String, FileName As String
Sarr = Split(SZ(0), "/")
FileName = Sarr(UBound(Sarr))
Dim Buffer() As Byte
If Zip.ReadFileByte(SZ(0), Buffer()) Then
    Set Picture1.Picture = PictureFromBits(Buffer)
  
    PutToFileBin App.Path & "\" & FileName, Buffer
    'MsgBox "ok"
Else
    MsgBox "err"
End If
End Sub
 
'
'Be sure to set "Break on Unhandled Errors" in the
'Tools|Options... dialog when testing in the IDE!
'
Private Sub Form_Load()
    Dim Crc As Long
    Dim Path As String
With Zip
        .OpenZip App.Path & "\test2.zip"
        '.OpenZip App.Path & "\sample.zip"
'        .FirstFile Path, crc
'        Do While Len(Path)
'            Text1.SelText = LCase$(Right$(String$(7, "0") & Hex$(crc), 8)) _
'                          & " " _
'                          & Path _
'                          & vbNewLine
'            .NextFile Path, crc
'        Loop
    Dim FileSizeArr() As Long, FileList() As String, CrcArr() As Long
    .GetFileList FileList, FileSizeArr, CrcArr
    Dim I As Long
    For I = 0 To UBound(FileList)
        List1.AddItem FileList(I) & Chr(9) & "  Size:" & FileSizeArr(I) & ",crc=" & LCase$(Right$(String$(7, "0") & Hex$(CrcArr(I)), 8))
    Next
      '  .CloseZip
    End With
    If List1.ListCount > 0 Then
        List1.ListIndex = 0
        Command1_Click
    End If
End Sub
 
Function PutToFileBin(FileName As String, bin() As Byte) As Boolean
   '[mycode_id:1940],edittime:2011/7/12 0:04:11
   On Error Resume Next
   Kill FileName
   On Error GoTo Err
       Dim hFile As Integer
       hFile = FreeFile
       Open FileName For Binary As #hFile
       Put #hFile, , bin
       Close #hFile
       PutToFileBin = True
   Exit Function
Err:
       MsgBox Err.Description
End Function
 
Private Sub List1_Click()
    Dim SZ
SZ = Split(List1, Chr(9))
Dim Sarr() As String, FileName As String
Sarr = Split(SZ(0), "/")
FileName = Sarr(UBound(Sarr))
Dim Buffer() As Byte
If Zip.ReadFileByte(SZ(0), Buffer()) Then
    Set Picture1.Picture = PictureFromBits(Buffer)
  
    'PutToFileBin App.Path & "\" & FileName, Buffer
    'MsgBox "ok"
Else
    MsgBox "err"
End If
End Sub

Private Declare Function unzOpen Lib "zlibwapi" ( _
    ByVal Path As String) As Long
Private Declare Function unzClose Lib "zlibwapi" ( _
    ByVal unzhFile As Long) As UnzipResults
Private Declare Function unzGoToFirstFile Lib "zlibwapi" ( _
    ByVal unzhFile As Long) As UnzipResults
Private Declare Function unzGoToNextFile Lib "zlibwapi" ( _
    ByVal unzhFile As Long) As UnzipResults
Private Declare Function unzReadCurrentFile Lib "zlibwapi" ( _
    ByVal unzhFile As Long, ByVal BufferPtr As Long, ByVal Size As Long) As UnzipResults
Private Declare Function unzOpenCurrentFile Lib "zlibwapi.dll" (ByVal unzhFile As Long) As Long
Private Declare Function unzCloseCurrentFile Lib "zlibwapi.dll" (ByVal unzhFile As Long) As Long
 
Private Declare Function unzGetCurrentFileInfo Lib "zlibwapi" ( _
    ByVal unzhFile As Long, _
    ByVal pFileInfo As Long, _
    ByVal FileName As String, _
    ByVal FileNameBufferSize As Long, _
    ByVal pExtraField As Long, _
    ByVal ExtraFieldBufferSize As Long, _
    ByVal Comment As String, _
    ByVal CommentBufferSize As Long) As UnzipResults