This project is a followup to [VB6] Basic unzip without 3rd party DLL or shell32- IStorage-based, to create a zip using the same method. At the time, I didn't know if it was possible, and later I thought you'd have to implement a custom IDataObject, so I hadn't thought it worth the effort. But I revisited this topic after a question, and found that with a couple workarounds for some weird errors, it's entirely possible to not only do it, but to do it without a custom IDataObject.
Requirements
-oleexp3.tlb 3.0 or higher.
-Windows XP or higher (the core ZipFiles() sub should work on XP, HOWEVER.. for simplicity the demo project uses Vista+ dialogs to choose files; you'll need a new way of selecting files for XP)
The Challenges
(background info, these are solved issues, not needed to use the code)
There were three very strange issues I had to work around. First, a reference needed to be created to the zip file being created. This reference was found by using the immediate parent folder and the relative pointer to that file... think of it as using "C:\folder" and "file.zip". That is used to get the drop target for the file (this method uses the drag-drop interface in code). folder is asked for the drop target for file.zip-- this fails. BUT.. if we combine them, and ask the desktop for the drop target for "C:\folder\file.zip", it succeeds. This makes very little sense to me.
The second issue was the error that had other people created their own IDataObject implementation. When you try to drop multiple files on an empty zip, you get an error saying that it can't add files to a new zip file because the new zip file is empty. Of course it's empty. A more detailed and app-crashing error says the IDataObject is invalid. Fortunately, by luck my initial test only tried to add one file. And this worked without producing the error. And if that wasn't bizarre enough, once that first file is added you can then add multiple files-- and not even one at a time, it will now accept the same type of multi-file IDataObject it errored on before.
Lastly, if 9 or more files were being added, Windows would display a compressed folders error (not an error in VB/the program) saying it couldn't find/read the first file. The first file would then not appear in the zip, but the rest would. But only on the first time files from that folder were added to a zip. But if that's the case, why wouldn't trying to add the other 8 files trigger the can't-add-multi-to-empty error?? Since it was an external error, I added a Sleep/DoEvents/Sleep routine to try to figure out where precisely the error was happening; but then since adding it I have not been able to reproduce the bug (it comes back without sleep). So please let me know if this one rears its head again... I think the solution at that point would to only add in blocks of 8.
The Code
Here's the core routine and its supporting APIs and functions:
Code:
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Declare Function ILCombine Lib "shell32" (ByVal pidl1 As Long, ByVal pidl2 As Long) As Long
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 SHCreateFileDataObject Lib "shell32" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp3.IDataObject) As Long
Public Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long ' Retrieves the IShellFolder interface for the desktop folder.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Const MK_LBUTTON = 1
Public Sub ZipFiles(sZipPath As String, pszToZip() As String)
Dim pZipStg As oleexp3.IStorage
Dim pZipStrm As oleexp3.IStream
Dim psfZipFolder As IShellFolder
Dim pidlZipFolder As Long
Dim pDT As IDropTarget
Dim pidlToZip() As Long
Dim idoToZip As oleexp3.IDataObject
'So weird bug... if you try to drop multiple files onto the newly created
'empty zip file, you get an error saying it can't create it because it's
'empty. stupid to begin with, of course it's empty to begin with. but even
'stupider, if you only drop 1 file, it works. so we have to only drop one
'file at first, then we can drop the rest
Dim pidlToZip2() As Long
Dim idoToZip2 As oleexp3.IDataObject
Dim pszZipFile As String 'name of zip file only, e.g. blah.zip
Dim pszZipFolder As String 'full path to folder that will contain .zip
Dim pidlZipFile As Long
Dim pchEaten As Long
Dim q As Long
Dim bMulti As Boolean
ReDim pidlZip(0)
ReDim pidlToZip(0)
pszZipFolder = Left$(sZipPath, InStrRev(sZipPath, "\") - 1)
pszZipFile = Right$(sZipPath, Len(sZipPath) - InStrRev(sZipPath, "\"))
Debug.Print "zipfolder=" & pszZipFolder
Debug.Print "zipfile=" & pszZipFile
pidlToZip(0) = ILCreateFromPathW(StrPtr(pszToZip(0)))
If UBound(pszToZip) > 0 Then
ReDim pidlToZip2(UBound(pszToZip) - 1)
For q = 1 To UBound(pszToZip)
pidlToZip2(q - 1) = ILCreateFromPathW(StrPtr(pszToZip(q)))
Next
bMulti = True
End If
pidlZipFolder = ILCreateFromPathW(StrPtr(pszZipFolder))
Set psfZipFolder = GetIShellFolder(isfDesktop, pidlZipFolder)
Set pZipStg = psfZipFolder 'this calls QueryInterface internally
If (pZipStg Is Nothing) Then
Debug.Print "Failed to create IStorage"
GoTo clnup
End If
Set pZipStrm = pZipStg.CreateStream(pszZipFile, STGM_CREATE, 0, 0)
If (pZipStrm Is Nothing) Then
Debug.Print "Failed to create IStream"
GoTo clnup
End If
psfZipFolder.ParseDisplayName 0&, 0&, StrPtr(pszZipFile), pchEaten, pidlZipFile, 0&
If pidlZipFile = 0 Then
Debug.Print "Failed to get pidl for zip file"
GoTo clnup
End If
Call SHCreateFileDataObject(VarPtr(0&), UBound(pidlToZip) + 1, VarPtr(pidlToZip(0)), ByVal 0&, idoToZip)
If (idoToZip Is Nothing) Then
Debug.Print "Failed to get IDataObject for ToZip"
GoTo clnup
End If
Dim pidlFQZF As Long
pidlFQZF = ILCombine(pidlZipFolder, pidlZipFile)
'This is very weird. Both psfZipFolder and pidlZipFile(0) are valid, but if we request the IDropTarget using those,
'pDT fails to be generated. But when the zip file's relative pidl is combined with the pidl for its folder, and
'passed to isfDesktop as a fully qualified pidl, it works
'psfZipFolder.GetUIObjectOf 0&, 1, pidlZipFile(0), IID_IDropTarget, 0&, pDT
isfDesktop.GetUIObjectOf 0&, 1, pidlFQZF, IID_IDropTarget, 0&, pDT
If (pDT Is Nothing) Then
Debug.Print "Failed to get drop target"
GoTo clnup
End If
pDT.DragEnter idoToZip, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY
pDT.Drop idoToZip, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY
If bMulti Then
Sleep 1500
DoEvents
Sleep 1500
Debug.Print "adding rest of files..."
Call SHCreateFileDataObject(VarPtr(0&), UBound(pidlToZip2) + 1, VarPtr(pidlToZip2(0)), ByVal 0&, idoToZip2)
If (idoToZip2 Is Nothing) Then
Debug.Print "Failed to get IDataObject for ToZip2"
GoTo clnup
End If
pDT.DragEnter idoToZip2, MK_LBUTTON, 0, 0, DROPEFFECT_COPY
pDT.Drop idoToZip2, MK_LBUTTON, 0, 0, DROPEFFECT_COPY
End If
'cleanup
clnup:
ILFree pidlToZip(0)
If bMulti Then
For q = 0 To UBound(pidlToZip2)
Call ILFree(pidlToZip2(q))
Next
End If
Call ILFree(pidlZipFile)
Call ILFree(pidlZipFolder)
Call ILFree(pidlFQZF)
End Sub
'-----------------------------
'Supporting functions
Public Function GetIShellFolder(isfParent As IShellFolder, pidlRel As Long) As IShellFolder
Dim isf As IShellFolder
On Error GoTo out
Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)
out:
If Err Or (isf Is Nothing) Then
Set GetIShellFolder = isfDesktop
Else
Set GetIShellFolder = isf
End If
End Function
Public Function isfDesktop() As IShellFolder
Static isf As IShellFolder
If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
Set isfDesktop = isf
End Function
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
'----------------------------------------------
'Below not needed in a project with mIID.bas
'----------------------------------------------
Private Function IID_IDropTarget() As UUID
'{00000122-0000-0000-C000-000000000046}
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_UUID(iid, &H122, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
IID_IDropTarget = iid
End Function
Private 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
Private 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
Private 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 SubIf you wanted to add to existing archive, it's just a few adjustments. All you'd have to do is skip over the parts that generate a new zip file, and go directly to getting an IDropTarget for it and dropping the file IDataObject. If there's enough interest I may add some sample code for this in the future.