[VB6] Create a ZIP file without any DLL depends using IStorage and IDropTarget

http://i.imgur.com/7iafmJz.jpg

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.

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).

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?

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.

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".

Through the common dialog? What OS? Just checked on Win7 and it added the .zip for me.

Quote:

---

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.:confused:

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 :thumb:

can u share demo about zip a whole folder?

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

---

when i pass this to pszToZip
zipfile.zip\folder\file1
zipfile.zip\folder\file2 etc
will it create "folder" in zipfile.zip automatically?

No, if that's what you want just use the first option and pass the folder itself. If there's subfolders it will preserve the structure too.

I zip a MDB file (access db) of 30MB size, and always a message box appears while zipping.
There is a way to hide this message box?

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.

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.

You can also use an alternative:
http://www.vbforums.com/showthread.p...om-VB-programs

Quote:

---

Originally Posted by Arnoutdv

You can also use an alternative:

---

Thanks Arnoutdv,
before already was using external libraries:
Zip and Unzip Using VB5 or VB6
http://www.codeguru.com/vb/gen/vb_gr...VB5-or-VB6.htm

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.

Thanks again.

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.

You are right. It's a progress message (see image)
I'm sorry for the mistake, but it appears only for a moment, and I am confused.

If it were a simple thing, okay. But in this case I give up. As I said it is not so important.
Thanks anyway.

:wave:

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.

Quote:

---

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.

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.

Yes, it was working, except I didn't like the Sleep, DoEvents, Sleep hack, as well as building two separate arrays.

Bruce

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

Quote:

---

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

---

Code:

---

**
ReDim Preserve sFilenames(UBound(sFilenames) + 1) 'Note workaround... must add additional empty file, otherwise last file dropped.
ZipFiles sFilename & ".zip", sFilenames()

---

Code:

---

'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

---

Code:

---

***
'Call without additional empty array position.
ZipFiles sFilename & ".zip", sFilenames()

---

So has anybody idea, why redimensioning is needed in the first place?

Quote:

---

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

Failed to get drop target

Which OS, and where are you trying to save the zip to? Did the save to textbox have a full path, e.g. C:\dir\saveto.zip ?

Quote:

---

Originally Posted by fafalone

Which OS, and where are you trying to save the zip to? Did the save to textbox have a full path, e.g. C:\dir\saveto.zip ?

---

i'm in win8.1,maybe test on win10.
my win8.1 maybe lose some dll

how to set password to zip?

Public Sub ZipFiles(sZipPath As String, pszToZip() As String, Optional Password As String)

This method does not support setting a password; I recommend wqweto's cZipArchive for that.

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.

DragEnter ？？Is there a way to drag and drop files from the explorer browser to a handle?

If you have the handle you should know the path, use the ZipAppend function in post #2.

Quote:

---

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.

Can you describe a use case in which this functionality is needed?

Quote:

---

Originally Posted by Arnoutdv

Can you describe a use case in which this functionality is needed?

---

use vb6 code,how to drop files to chrome.exe webpage area
for auto upload files

I gave you a link describing a way to do this in the other thread where you asked.

maybe:
sendmessage dropfiles()
sendmessage hwnd,mouse left down,xy,y

send message hwnd mouse left up

dropping files from Explorer onto a CHROME HANDLE

Quote:

---

Originally Posted by fafalone

https://learn.microsoft.com/en-us/an...rop-from-my-lo

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.

---