Reading ZIP and DOCX files and unpacking image files in memory

[HackerVlad]

I wrote a program that scans the contents of ZIP, DOCX, XLSX, and EXE files, reads the entire file structure inside archives and without temporary files, unpacks and displays images in memory.
It even works with all nested subfolders. I improved the code from The trick.
Requirement: olelib.tlb or oleexp.tlb library.

This illustrative example shows how easy it is to unpack any ZIP file and read its contents, as well as SFX EXE files and DOCX files. Works in WinXP+

Form code:

Option Explicit
Private Declare Function SHParseDisplayName Lib "shell32" (ByVal pszName As Long, ByVal IBindCtx As Long, ByRef ppidl As Long, sfgaoIn As Long, sfgaoOut As Long) As Long
Private Declare Function ILFree Lib "shell32" (ByVal pidlFree As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Const ZipFldrCLSID = "{E88DCCE0-B7B3-11d1-A9F0-00AA0060FA31}"
Private Const IID_IShellExtInit = "{000214E8-0000-0000-C000-000000000046}"

Private Sub ReadingStructureZIP(ByVal FileName As String)
    Dim clsid   As UUID
    Dim iidSh   As UUID
    Dim shExt   As IShellExtInit
    Dim pf      As IPersistFolder2
    Dim pidl    As Long
    
    CLSIDFromString ZipFldrCLSID, clsid
    CLSIDFromString IID_IShellExtInit, iidSh
    
    If CoCreateInstance(clsid, Nothing, CLSCTX_INPROC_SERVER, iidSh, shExt) <> S_OK Then Exit Sub
    Set pf = shExt
    SHParseDisplayName StrPtr(FileName), 0, pidl, 0, 0
    pf.Initialize pidl
    ILFree pidl
    
    IStorageRead pf
End Sub

Private Sub IStorageRead(IStorageInZIP As IStorage, Optional PathFolder As String)
    Dim enm As IEnumSTATSTG
    Dim itm As STATSTG
    Dim nam As String
    Dim cb As Long
    
    Set enm = IStorageInZIP.EnumElements
    
    enm.Reset
    Do While enm.Next(1, itm) = S_OK
        nam = SysAllocString(itm.pwcsName)
        CoTaskMemFree itm.pwcsName
        
        If itm.Type = STGTY_STREAM Then
            List1.AddItem IIf(PathFolder <> "", PathFolder & "\" & nam, nam) & IIf(itm.cbSize, "    " & itm.cbSize * 10000@ & " bytes", "")
        ElseIf itm.Type = STGTY_STORAGE Then
            IStorageRead IStorageInZIP.OpenStorage(nam, 0, STGM_READ, 0, 0), IIf(PathFolder <> "", PathFolder & "\" & nam, nam)
        End If
    Loop
End Sub

Private Sub LoadFileFromZIP(ByVal FileName As String, ByVal FileNameInZIP As String)
    Dim clsid   As UUID
    Dim iidSh   As UUID
    Dim shExt   As IShellExtInit
    Dim pf      As IPersistFolder2
    Dim pidl    As Long
    
    CLSIDFromString ZipFldrCLSID, clsid
    CLSIDFromString IID_IShellExtInit, iidSh
    
    If CoCreateInstance(clsid, Nothing, CLSCTX_INPROC_SERVER, iidSh, shExt) <> S_OK Then Exit Sub
    Set pf = shExt
    SHParseDisplayName StrPtr(FileName), 0, pidl, 0, 0
    pf.Initialize pidl
    ILFree pidl
    
    LoadPictureFileFromZIP pf, FileNameInZIP
End Sub

Private Sub LoadPictureFileFromZIP(IStorageInZIP As IStorage, ByVal FileNameInZIP As String, Optional PathFolder As String)
    Dim enm As IEnumSTATSTG
    Dim itm As STATSTG
    Dim nam As String
    Dim cb As Long
    Dim FileName As String
    Dim stm As IStream
    
    Set enm = IStorageInZIP.EnumElements
    
    enm.Reset
    Do While enm.Next(1, itm) = S_OK
        nam = SysAllocString(itm.pwcsName)
        CoTaskMemFree itm.pwcsName
        FileName = IIf(PathFolder <> "", PathFolder & "\" & nam, nam)
        
        If itm.Type = STGTY_STREAM Then
            If FileName = FileNameInZIP Then
                Set stm = IStorageInZIP.OpenStream(nam, 0, STGM_READ, 0)
                If itm.cbSize Then Picture1.Picture = LoadPictureFromStream(stm)
                Set stm = Nothing
            End If
        ElseIf itm.Type = STGTY_STORAGE Then
            LoadPictureFileFromZIP IStorageInZIP.OpenStorage(nam, 0, STGM_READ, 0, 0), FileNameInZIP, FileName
        End If
    Loop
End Sub

Private Sub Form_Load()
    Text1.Text = App.Path & "\test.docx"
    ReadingStructureZIP Text1.Text
    
    If List1.ListCount > 0 Then
        List1.Selected(0) = True
        Label1.Caption = "Count files: " & List1.ListCount
    End If
End Sub

Private Sub List1_Click()
    Dim tick As Long
    
    tick = GetTickCount
    LoadFileFromZIP Text1.Text, Mid$(List1.Text, 1, InStr(1, List1.Text, "    ") - 1)
    Label2.Caption = "ms: " & (GetTickCount - tick)
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        
        List1.Clear
        ReadingStructureZIP Text1.Text
        
        If List1.ListCount > 0 Then
            List1.Selected(0) = True
            Label1.Caption = "Count files: " & List1.ListCount
            List1.SetFocus
        End If
    End If
End Sub

Module code (loading images from memory):

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PicBmp
    size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Declare Function GdipCreateBitmapFromStream Lib "gdiplus" (ByVal Stream As IUnknown, ByRef hBitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal BITMAP As Long, hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal Token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long

Public Function LoadPictureFromStream(FileStream As IUnknown, Optional BackColor As Long = vbWhite) As StdPicture
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID
    Dim SI As GdiplusStartupInput
    Dim Token As Long
    Dim bmp As Long
    Dim hBmp As Long
    
    SI.GdiplusVersion = 1
    
    If GdiplusStartup(Token, SI) Then Exit Function
    If GdipCreateBitmapFromStream(FileStream, bmp) = 0 Then
        If GdipCreateHBITMAPFromBitmap(bmp, hBmp, BackColor) = 0 Then
            GdipDisposeImage (bmp)
        End If
        GdiplusShutdown Token
    Else
        GdiplusShutdown Token
    End If
    
    With IID_IDispatch
       .Data1 = &H20400
       .Data4(0) = &HC0
       .Data4(7) = &H46
    End With
    With Pic
       .size = Len(Pic)          ' Length of structure.
       .Type = vbPicTypeBitmap   ' Type of Picture (bitmap).
       .hBmp = hBmp              ' Handle to bitmap.
       .hPal = 0
    End With
    
    OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
    
    Set LoadPictureFromStream = IPic
End Function