[VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
About
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
-oleexp.tlb 4.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 oleexp.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 oleexp.IStorage
Dim pZipStrm As oleexp.IStream
Dim psfZipFolder As IShellFolder
Dim pidlZipFolder As Long
Dim pDT As IDropTarget
Dim pidlToZip() As Long
Dim idoToZip As oleexp.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 oleexp.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:
CoTaskMemFree pidlToZip(0)
If bMulti Then
For q = 0 To UBound(pidlToZip2)
Call CoTaskMemFree(pidlToZip2(q))
Next
End If
Call CoTaskMemFree(pidlZipFile)
Call CoTaskMemFree(pidlZipFolder)
Call CoTaskMemFree(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 Sub
Existing Archives
If 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.
Project Update 24 Nov 2016 - Updated project to reference oleexp.tlb v4.0 and higher
(2018 Sep 08) NOTE: ILFree should not be used. Code in this post and below changed to use CoTaskMemFree instead. Recommend making change in project if you DL it. oleexp has the declare, so just need to change the calls.
Last edited by fafalone; Sep 7th, 2018 at 12:12 AM.
Reason: Bug fix : ILFree->CoTaskMemFree
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Here's a ZipAppend function... you could just call this if the file exists instead of the create function. This will work with "new" zip files; e.g. if you selected create new zip from Explorer's right-click menu, but not completely empty (0-byte) or non-existent files. sFiles() must contain all full paths for each file to add.
Code:
Public Sub ZipAppend(sZipFile As String, sFiles() As String)
Dim pDT As IDropTarget
Dim pDataObj As oleexp.IDataObject
Dim pidls() As Long
Dim pidlZip As Long
Dim i As Long
pidlZip = ILCreateFromPathW(StrPtr(sZipFile))
isfDesktop.GetUIObjectOf 0&, 1&, pidlZip, IID_IDropTarget, 0&, pDT
If (pDT Is Nothing) = False Then
ReDim pidls(UBound(sFiles))
For i = 0 To UBound(sFiles)
pidls(i) = ILCreateFromPathW(StrPtr(sFiles(i)))
Next
Call SHCreateFileDataObject(VarPtr(0&), UBound(pidls) + 1, VarPtr(pidls(0)), ByVal 0&, pDataObj)
If (pDataObj Is Nothing) = False Then
pDT.DragEnter pDataObj, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY
pDT.Drop pDataObj, MK_LBUTTON, 0&, 0&, DROPEFFECT_COPY
Else
Debug.Print "ZipAppend::Failed to get IDataObject for files."
End If
For i = 0 To UBound(pidls)
CoTaskMemFree pidls(i)
Next
Else
Debug.Print "ZipAppend: Failed to get drop target for destination zip file."
End If
CoTaskMemFree pidlZip
End Sub
I've noted it here as ZipAppend, but this code doubles as a generic drop-in-Explorer method. You could specify a folder, or any other file you could drop on in Explorer, and it will work fine (the code here is slightly limited in that it won't work on some virtual items due to using a path string and pidl; but for normal file system objects it works as-is).
Last edited by fafalone; Sep 7th, 2018 at 12:03 AM.
Reason: Bug fix: ILFree->CoTaskMemFree
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
As with any complex project, I know it looks cool and you want to dive right in, but I typed out all that text in the post for a good reason
As noted in the 'Requirements' section, oleexp3.tlb is a dependency. It's linked there, and here's a direct link to the project page. As it's a general purpose typelib shared amongst many projects, it should be placed in a common directory rather than in each project folder (or you'll run into problems down the road). After you extract it, go to Project-References and add oleexp3.tlb as a reference. This is only required in the IDE; you won't need to include it with your installation.
Last edited by fafalone; Dec 18th, 2015 at 04:32 PM.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Thanks a lot, and yes, I wanted to dive in and forgot to read ;-)
The zip example works fine. Small glitch: If user doesn't write the .zip extension, a file with no extension and 0 bytes will be created, despite the .SetDefaultExtension ".zip".
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Originally Posted by fafalone
Through the common dialog? What OS? Just checked on Win7 and it added the .zip for me.
Win7-64. And I know this is impossible, but sometimes it adds the .zip, sometimes it doesn't.
If user simply types test or test.zip, another problem pops up here:
pszZipFolder = Left$(sZipPath, InStrRev(sZipPath, "\") - 1)
I am new to VB6 (but not to VBA), so I assume Left$ doesn't like the negative index. My pet dialects (Gfa, MasmBasic) would just take the whole string if index<0).
But anyway, this is just cosmetics - you did a great job
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
If you want to zip a whole folder you can just pass the folder path in pszToZip
zipfile.zip\folder\file1
zipfile.zip\folder\file2 etc
If you really want the zip to just start inside the folder instead of with the folder, you could always fill it with the contents...
zipfile.zip\file1
zipfile.zip\file2 etc
Code:
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim pChild As IShellItem
Dim lpPath As Long
Dim szPath As String
Dim nPaths As Long
Dim pclt As Long
Call SHCreateItemFromParsingName(StrPtr("C:\folder"), ByVal 0&, IID_IShellItem, psi) 'oleexp 4.1::use Nothing instead of ByVal 0& if using API in TLB
If psi Is Nothing Then Exit Sub
ReDim sOut(0)
psi.BindToHandler 0, BHID_EnumItems, IID_IEnumShellItems, piesi
Do While (piesi.Next(1, pChild, pclt) = S_OK)
pChild.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpPath
szPath = LPWSTRtoStr(lpPath)
If szPath <> "" Then
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
Set pChild = Nothing
Loop
Last edited by fafalone; Dec 4th, 2016 at 07:30 PM.
Reason: Fix szPath check
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Do you mean a message box that you have to respond to? Or the progress dialog?
There's no way to hide the progress dialog.. the method here just hands it off to Explorer, executing a drop onto a zip file through code. Can you do it when creating a zip file in Explorer, like by holding a key combo down or changing a setting somewhere? If so that can probably be replicated, but short of that you'd have to go with one of the more traditional zip dlls to customize things at all.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
It 'a simple message box (no progress bar) and, of course, the creation of the zip is done using only VB6 code.
Unfortunately, at present, they are not in the office, and I can not show you any pictures. Just back in office I will provide more information.
Meanwhile to thank. Happy Holidays.
but I need to implement both zip/unzip just using VB6 code, no external DLLs.
I implemented the fafalone sample code (merged zip/unzip into a single class) and I am very satisfied, it works perfectly!
Just showing a message during compression.
This message does not really bothered you, but if I could hide I would be happier.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
I'm pretty sure you mean the progress message...
If you really really wanted to, you could write a loop to search for it and hide it with FindWindow or similar. But if it happens when zipping in Explorer too any option to hide it would have to be an undocumented registry key or something, since the VB-side code is just a fancy way of invoking a drag-drop.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
If your concern is that the dialog is interfering with your program, note that it's not modal and an asynchronous operation- after it's called, it returns immediately and execution continues while Explorer does its own thing. So you could, immediately after calling the zip operation, add a set focus call to return your app to the foreground that the status message had taken away.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Originally Posted by fafalone
The Challenges
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.
I believe that both these issues are solved by first creating the file and adding the 22 bytes for the End of Central Directory Record (EOCD). I used a snippet of code from Bonnie West to do this as a test:
Code:
'Creates a new empty Zip file only if it doesn't exist.
Private Function CreateNewZip(ByRef sFileName As String) As Boolean
With CreateObject("Scripting.FileSystemObject") 'Late-bound
'With New FileSystemObject 'Referenced
On Error GoTo 1
With .CreateTextFile(sFileName, Overwrite:=False)
.Write "PK" & Chr$(5&) & Chr$(6&) & String$(18&, vbNullChar)
.Close
1 End With
End With
CreateNewZip = (Err = 0&)
End Function
It seemed to solve the problem. I inserted it just before this line in ZipFiles:
Code:
Set pZipStrm = pZipStg.CreateStream(pszZipFile, STGM_CREATE, 0, 0)
and modified that line to:
Code:
Set pZipStrm = pZipStg.OpenStream(pszZipFile, STGM_READWRITE, 0, 0)
Now it seems that I need to use ISequentialStream::Write to add those bytes to the stream just after creating it, then add all the files using SHCreateFileDataObject using only pidlToZip, not pidlToZip2.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
That sounds like a much better way to avoid the issue entirely; but was the problem still happening under some OS/condition with the existing workaround, because on my Win7/Win8 test the existing steps should have been working. Just curious; I'll probably switch it to the better method.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
This seems to work:
Code:
Option Explicit
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Declare Function ILCombine Lib "shell32.dll" (ByVal pidl1 As Long, ByVal pidl2 As Long) As Long
Public Declare Function ILCreateFromPathW Lib "shell32.dll" (ByVal pwszPath As Long) As Long
Public Declare Sub ILFree Lib "shell32.dll" (ByVal pidl As Long)
Public Declare Function SHCreateFileDataObject Lib "shell32.dll" Alias "#740" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pDataInner As Any, ppDataObj As oleexp.IDataObject) As Long
Public Declare Function SHGetDesktopFolder Lib "shell32.dll" (ppshf As IShellFolder) As Long ' Retrieves the IShellFolder interface for the desktop folder.
Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Declare Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As Long) As Long
Public Const MK_LBUTTON = 1
Public Sub ZipFiles(sZipPath As String, pszToZip() As String)
Dim pZipStg As oleexp.IStorage
Dim pZipStrm As oleexp.IStream
Dim psfZipFolder As IShellFolder
Dim pidlZipFolder As Long
Dim pDT As IDropTarget
Dim pidlToZip() As Long
Dim idoToZip As oleexp.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
Dim pvEOCD() As Byte
Dim hResult As Long
Dim pidlFQZF As Long
Dim cq As Long
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
If UBound(pszToZip) > 0 Then
ReDim pidlToZip(UBound(pszToZip) - 1)
For q = 0 To UBound(pszToZip) - 1
pidlToZip(q) = ILCreateFromPathW(StrPtr(pszToZip(q)))
Next
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 Cleanup
End If
Set pZipStrm = pZipStg.CreateStream(pszZipFile, STGM_CREATE, 0, 0)
If (pZipStrm Is Nothing) Then
Debug.Print "Failed to create IStream"
GoTo Cleanup
End If
' Add the End of Central Directory Record (EOCD) to the Stream
Set pZipStrm = pZipStg.OpenStream(pszZipFile, 0, STGM_WRITE, 0)
pvEOCD = StrConv("PK" & Chr$(5&) & Chr$(6&) & String$(18&, vbNullChar), vbFromUnicode)
hResult = pZipStrm.Write(ByVal VarPtr(pvEOCD(0)), 22)
Set pZipStrm = pZipStg.OpenStream(pszZipFile, 0, STGM_READ, 0)
psfZipFolder.ParseDisplayName 0&, 0&, StrPtr(pszZipFile), pchEaten, pidlZipFile, 0&
If pidlZipFile = 0 Then
Debug.Print "Failed to get pidl for zip file"
GoTo Cleanup
End If
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
isfDesktop.GetUIObjectOf 0&, 1, pidlFQZF, IID_IDropTarget, 0&, pDT
If (pDT Is Nothing) Then
Debug.Print "Failed to get drop target"
GoTo Cleanup
End If
Debug.Print "adding the files..."
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 ToZip2"
GoTo Cleanup
End If
For cq = 0 To UBound(pidlToZip)
Debug.Print "file" & cq & "=" & GetPathFromPIDLW(pidlToZip(cq))
Next
pDT.DragEnter idoToZip, MK_LBUTTON, 0, 0, DROPEFFECT_COPY
pDT.Drop idoToZip, MK_LBUTTON, 0, 0, DROPEFFECT_COPY
Cleanup:
For q = 0 To UBound(pidlToZip) - 1
Call ILFree(pidlToZip(q))
Next
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 Hell
Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)
Hell:
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 Sub
Public Function GetPathFromPIDLW(pidl As Long) As String
Dim pszPath As String
pszPath = String(MAX_PATH, 0)
If SHGetPathFromIDListW(pidl, StrPtr(pszPath)) Then
If InStr(pszPath, vbNullChar) Then
GetPathFromPIDLW = Left$(pszPath, InStr(pszPath, vbNullChar) - 1)
End If
End If
End Function
Bruce
Last edited by OlsonSound; Jun 5th, 2017 at 09:35 PM.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Originally Posted by OlsonSound
This seems to work:
Bruce
Not quite... Zipfiles function drops last file to be zipped from pszToZip() array.
Code:
If UBound(pszToZip) > 0 Then
ReDim pidlToZip(UBound(pszToZip) - 1) 'Array is redimensioned, so last file dropped.
For q = 0 To UBound(pszToZip) - 1 'Yet again here errorneously? counted one file less, but somehow seems to work**.
pidlToZip(q) = ILCreateFromPathW(StrPtr(pszToZip(q)))
Next
End If
'Modified code... This does not work either. ***
If UBound(pszToZip) > 0 Then
' ReDim pidlToZip(UBound(pszToZip) - 1) 'Line commented out
For q = 0 To UBound(pszToZip) 'Corrected? -> but now causes out of bounds error.
pidlToZip(q) = ILCreateFromPathW(StrPtr(pszToZip(q)))
Next
End If
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Originally Posted by jj2007
Hi fafalone,
Looks very interesting but when hitting F5, vb complains that OLEEXP is missing - apparently one of your babies. Where can I find it?
Reference=*\G{F9015E81-CAAC-45C0-94E8-42B7DA5D7557}#4.3#0#..\..\Windows\SysWow64\oleexp.tlb#OLEEXP - olelib With Modern Interfaces by fafalone, v4.3
Reference=*\G{F9015E81-CAAC-45C0-94E8-42B7DA5D7557}#4.3e#0#..\..\Windows\SysWow64\oleexp.tlb#OLEEXP - olelib With Modern Interfaces v4.62
Reference=*\G{F9015E81-CAAC-45C0-94E8-42B7DA5D7557}#4.6#0#..\..\Windows\SysWow64\oleexp.tlb#OLEEXP - olelib With Modern Interfaces v4.6
Reference=*\G{F9015E81-CAAC-45C0-94E8-42B7DA5D7558}#4.7#0#C:\Windows\SysWow64\oleexp.tlb#OLEEXP - Modern Shell Interfaces for VB6, v4.7
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Microsoft often drags its feet on these basic features.For example, Google invented the web socket,
and it took him many years to realize it.
The.net core is compiled into a separate file. It was also realized recently. If it was realized in 2005, it would be a perfect thing.
Re: [VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget
Originally Posted by fafalone
If you have the handle you should know the path, use the ZipAppend function in post #2.
I mean open an Explorer folder, then select a file, drag and drop it into the file upload area of Google Chrome.
In the past, to upload a file, you needed to click a button, and then select a local file. It would pop up a file selection dialog box. Finally, the file name would be written into a text box on the web page.
This text box cannot be set directly, only by selecting a file.
Now a new generation of web browsers, it can change a way, drag and drop files directly to the browser page.
How to automate this step through the program?
For example, 100% simulate the mouse to select a file, and then drag and drop it.
Or operate in the background through Google Drive.
It's VB.NET but should be easy enough to translate to VB6, just be careful with the INPUT stuff, search for existing threads on that as it's a little tricky.