[VB6] Basic unzip without 3rd party DLL or shell32- IStorage-based

[fafalone]

So the only other method I've really seen to extract zip archives without shell32 or a 3rd party DLL is a full implementation of the ZIP algorithm, and while this isn't exactly a lightweight method, it's not nearly as complex as that was with all its class modules. As I've mentioned a few times, I'm definitely not a fan of the shell32 object, and I came across an unzip method using things I do like: shell interfaces. Thanks to low-level Windows ZIP integration, it's possible to extract the contents of a simple ZIP archive (doesn't support password-protected zips for example) using IStorage, IStream, and some API.

Requirements
A type library with IStorage and IStream is required, and I strongly recommend using oleexp for future compability (get it here)- Project has been updated to reference oleexp 4.0 or higher.

This method is compatible with Windows XP and higher, but note the sample project for simplicity has a Vista+ FileOpen

Code
Below is a free-standing module you can use without anything else in the demo project (besides oleexp or olelib with changes):

Option Explicit

Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Sub ILFree Lib "shell32" (ByVal pidl As Long)
Public Declare Function SHBindToParent Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any, pidlLast As Long) As Long
Public Declare Function SHCreateStreamOnFileEx Lib "shlwapi" (ByVal pszFile As Long, ByVal grfMode As STGM, ByVal dwAttributes As FILE_ATTRIBUTES, ByVal fCreate As Long, ByVal pstmTemplate As Long, ppstm As oleexp.IStream) As Long
Public Declare Function PathFileExistsW Lib "shlwapi" (ByVal lpszPath As Long) As Long
Public Declare Function CreateDirectoryW Lib "kernel32" (ByVal lpPathName As Long, ByVal lpSecurityAttributes As Any) As Long
Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Const NOERROR = 0&
Public Const FILE_ATTRIBUTE_NORMAL = &H80

Public Sub UnzipFile(sFile As String, Optional ByVal sTo As String = "")
'unzip without 3rd party dll
Dim psfParent As oleexp.IShellFolder
Dim pidlFQ As Long
Dim pidlChild As Long
Dim pszDest As String

If sTo = "" Then
    'defaults to create a folder with the zip's name in the same folder as the zip
    pszDest = sFile
    pszDest = Left$(pszDest, Len(pszDest) - 4) 'remove .zip
Else
    pszDest = sTo
End If

'First, we need the parent pidl, child pidl, and IShellFolder
'These are all references to the file very common in shell programming
pidlFQ = ILCreateFromPathW(StrPtr(sFile))
Call SHBindToParent(pidlFQ, IID_IShellFolder, psfParent, pidlChild)
If (psfParent Is Nothing) Or (pidlChild = 0) Then
    Debug.Print "UnzipFile.Failed to bind to file"
    Exit Sub
End If

'Now that we have the IShellFolder, we want the IStorage object
'That is what we'll be able to extract from, thanks to the
'very low level system zip integration with zipfldr.dll
Dim pStg As oleexp.IStorage
psfParent.BindToObject pidlChild, 0, IID_IStorage, pStg
If (pStg Is Nothing) Then
    Debug.Print "UnzipFile.Failed to bind to storage"
    Exit Sub
End If
Debug.Print "UnzipFile.extract to " & pszDest

StgExtract pStg, pszDest

Set pStg = Nothing
Set psfParent = Nothing
ILFree pidlFQ


End Sub
Private Sub StgExtract(pStg As oleexp.IStorage, pszTargetDir As String, Optional fOverwrite As Long = 0)
'This function is recursively called to extract zipped files and folders

'First, create the target directory (even if you're extracting to an existing folder, it create subfolders from the zip)
If (PathFileExistsW(StrPtr(pszTargetDir)) = 0) Then
    Call CreateDirectoryW(StrPtr(pszTargetDir), ByVal 0&)
    If (PathFileExistsW(StrPtr(pszTargetDir)) = 0) Then
        Debug.Print "StgExtract.Failed to create directory " & pszTargetDir
        Exit Sub
    End If
End If

'The enumerator will loop through each storage object
'Here, that will be zipped files and folders
Dim pEnum As IEnumSTATSTG
Set pEnum = pStg.EnumElements(0, 0, 0)
If (pEnum Is Nothing) Then
    Debug.Print "StgExtract.pEnum==nothing"
    Exit Sub
End If

Dim celtFetched As Long
Dim stat As STATSTG
Dim pszPath As String

    Do While (pEnum.Next(1, stat, celtFetched) = NOERROR)
        pszPath = SysAllocString(stat.pwcsName) 'contains a file name
'        Debug.Print "pszPath on alloc=" & pszPath
        If (Len(pszPath) > 1) Then
            pszPath = AddBackslash(pszTargetDir) & pszPath 'combine that with the path (recursive, so can be zipped folder path)
'            Debug.Print "pszPath on combine=" & pszPath
            If stat.Type = STGTY_STORAGE Then 'subfolder
                Dim pStgSubfolder As oleexp.IStorage
                Set pStgSubfolder = pStg.OpenStorage(SysAllocString(stat.pwcsName), 0, STGM_READ, 0, 0)
                If (pStgSubfolder Is Nothing) Then
                    Debug.Print "StgExtract.pstgsubfolder==nothing"
                    Exit Sub
                End If
                StgExtract pStgSubfolder, pszPath 'and if there's more subfolders, we'll go deeper
            ElseIf stat.Type = STGTY_STREAM Then 'file
                'the basic idea here is that we obtain an IStream representing the existing file,
                'and an IStream representing the new extracted file, and copy the contents into the new file
                Dim pStrm As oleexp.IStream
                Set pStrm = pStg.OpenStream(SysAllocString(stat.pwcsName), 0, STGM_READ, 0)
                Dim pStrmFile As oleexp.IStream
                
                'here we add an option to not overwrite existing files; but the default is to overwrite
                'set fOverwrite to anything non-zero and the file is skipped
                'If we are extracting it, we call an API to create a new file with an IStream to write to it
                If PathFileExistsW(StrPtr(pszPath)) Then
                    If fOverwrite Then
                        Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
                    End If
                Else
                    Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
                End If
                If (pStrmFile Is Nothing) = False Then
                    'Debug.Print "StgExtract.Got pstrmfile"
                    Dim cbSize As Currency 'the STATSTG cbSize is ULONGLONG (equiv. to Currency), so files >2GB should be fine
                    pStrm.CopyTo pStrmFile, stat.cbSize, 0, cbSize
                    Set pStrmFile = Nothing
                    'Debug.Print "StgExtract.bytes written=" & CStr(cbSize)
                Else
                    'either an error or skipped an existing file; either way we don't exit, we'll move on to the next
                    'Debug.Print "StgExtract.pstrmfile==nothing"
                End If
                Set pStrm = Nothing
            End If
        End If
        pszPath = ""
        Call CoTaskMemFree(stat.pwcsName) 'this memory needs to be freed, otherwise you'll leak memory
    Loop
    
    Set pEnum = Nothing
    

End Sub
Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
    Call CoTaskMemFree(lPtr)
End If
End Function
Public Function AddBackslash(s As String) As String

   If Len(s) > 0 Then
      If Right$(s, 1) <> "\" Then
         AddBackslash = s & "\"
      Else
         AddBackslash = s
      End If
   Else
      AddBackslash = "\"
   End If

End Function

Public Function IID_IStorage() As UUID
'({0000000B-0000-0000-C000-000000000046})
Static iid As UUID
 If (iid.Data1 = 0) Then Call DEFINE_OLEGUID(iid, &HB, 0, 0)
 IID_IStorage = iid
End Function

'-----------------------------------------------------------
'Below this is not needed if you're using mIID.bas
'(check if the above IID_IStorage exists or not, because this was released before the update that included it)
'-----------------------------------------------------------
Public Sub DEFINE_UUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
  With Name
    .Data1 = L
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
End Sub
Public Sub DEFINE_OLEGUID(Name As UUID, L As Long, w1 As Integer, w2 As Integer)
  DEFINE_UUID Name, L, w1, w2, &HC0, 0, 0, 0, 0, 0, 0, &H46
End Sub
Public Function IID_IShellFolder() As UUID
  Static iid As UUID
  If (iid.Data1 = 0) Then Call DEFINE_OLEGUID(iid, &H214E6, 0, 0)
  IID_IShellFolder = iid
End Function

If anyone knows how I could add password support or create a zip file, definitely post ideas in the comments as I'll be working on it.

Thanks
This code is based on code using this method in C by sapero, found here.


UPDATE
For Vista and higher, a really nice complement to this project is to use IExplorerBrowser to have an interactive display of the contents of the zip:

With that being a full Explorer frame, you can interact with it like you would normally- you can drag and drop from there, navigate subfolders, etc, all automatically- the only code required is to initialize it:

Private pEB As ExplorerBrowser
Private psiRes As IShellItem 'remove Dim of psiRes from Command1_Click !

Private Sub NavigateZip(pObj As IShellItem)
'pObj here would be the psiResult IShellItem from .GetResult in the code
'for picking a zip with pOpenDlg in Command1_Click:
'Delete: Set psiRes = Nothing
'And replace with:  NavigateZip psiRes

If (pEB Is Nothing) Then
    Set pEB = New ExplorerBrowser
    Dim prc As oleexp.RECT
    Dim pfs As FOLDERSETTINGS
    
    pfs.fFlags = FWF_ALIGNLEFT
    pfs.ViewMode = FVM_DETAILS
    prc.Top = 15
    prc.Bottom = (Frame1.Height / 15) - 5
    prc.Left = 5
    prc.Right = (Frame1.Width / 15) - 5
    
    pEB.Initialize Frame1.hWnd, prc, pfs
    pEB.SetOptions EBO_NONE
End If

pEB.BrowseToObject pObj, 0&

End Sub

'also, to resize:
Private Sub Form_Resize()
Frame1.Width = Me.Width - 300
Frame1.Height = Me.Height - 1530
If (pEB Is Nothing) = False Then
    Dim hr As Long
    Dim prc As oleexp.RECT
    Dim lpph As Long
    prc.Top = 15
    prc.Bottom = (Frame1.Height / 15) - 5
    prc.Left = 5
    prc.Right = (Frame1.Width / 15) - 5
    hr = pEB.SetRect(lpph, prc.Left, prc.Top, prc.Right, prc.Bottom)
End If
End Sub

As one more added bonus, using Extract All or dragging out a file using the browser supports passwords.

One final thing, the question came up about zip files that don't have the .zip extension, like .xlsm and other Office documents. Here's how to check inside the file for the signature. This method is extremely fast despite having to open the file, so can even replace entirely checking the extension.

Public Function PathIsZipEx(sPath As String) As Boolean
'performs a hard check on a file by opening it and checking for the ZIP signature
'A valid ZIP begins with 0x50,0x4b,0x03,0x04 as the first four bytes.
'If it's an empty zip, it's 0x50,0x4b,0x05,0x06-- this function doesn't count that as valid,
'but if so desired just add an additional check
On Error GoTo Done
Dim aBytes() As Byte
Dim pStrm As oleexp.IStream
Dim hr As Long

hr = SHCreateStreamOnFileEx(StrPtr(sPath), STGM_READ, FILE_ATTRIBUTE_NORMAL, 0&, 0&, pStrm)
If hr = S_OK Then
    ReDim aBytes(3)
    pStrm.Read aBytes(0), 4&
    If (aBytes(0) = &H50) And (aBytes(1) = &H4B) And (aBytes(2) = &H3) And (aBytes(3) = &H4) Then
        PathIsZipEx = True
    End If
Else
    Debug.Print "PathIsZipEx.Error->SHCreateStreamOnFileEx failed to create IStream; hr=0x" & Hex$(hr) & ", file=" & sPath
End If
Done:
Set pStrm = Nothing
End Function

------------------
Note: The file I uploaded was named UnzipNew.zip, I have no idea why VBForums keeps renaming it to U.zip. Have tried removing and reattaching several times.