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:
Module code (loading images from 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:
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 SubCode:
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