dcsimg
Results 1 to 24 of 24

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

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

    [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.
    Attached Files Attached Files

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

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

  3. #3
    Lively Member jj2007's Avatar
    Join Date
    Dec 2015
    Posts
    122

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

    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?

  4. #4

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

    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.

  5. #5
    Lively Member jj2007's Avatar
    Join Date
    Dec 2015
    Posts
    122

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

  6. #6

  7. #7
    Lively Member jj2007's Avatar
    Join Date
    Dec 2015
    Posts
    122

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

    Quote Originally Posted by fafalone View Post
    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

  8. #8
    Addicted Member
    Join Date
    Jan 2015
    Posts
    172

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

    can u share demo about zip a whole folder?

  9. #9

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

    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

  10. #10
    Addicted Member
    Join Date
    Jan 2015
    Posts
    172

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

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

  11. #11

  12. #12
    Frenzied Member gibra's Avatar
    Join Date
    Oct 2009
    Location
    ITALY
    Posts
    1,668

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

    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?

  13. #13

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

    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.

  14. #14
    Frenzied Member gibra's Avatar
    Join Date
    Oct 2009
    Location
    ITALY
    Posts
    1,668

    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.

  15. #15
    PowerPoster Arnoutdv's Avatar
    Join Date
    Oct 2013
    Posts
    3,619

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


  16. #16
    Frenzied Member gibra's Avatar
    Join Date
    Oct 2009
    Location
    ITALY
    Posts
    1,668

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

    Quote Originally Posted by Arnoutdv View Post
    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.

  17. #17

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

    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.

  18. #18
    Frenzied Member gibra's Avatar
    Join Date
    Oct 2009
    Location
    ITALY
    Posts
    1,668

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

    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.

    Attached Images Attached Images  

  19. #19

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

    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.

  20. #20
    New Member
    Join Date
    May 2012
    Posts
    4

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

    Quote Originally Posted by fafalone View Post
    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.

  21. #21

    Thread Starter
    PowerPoster
    Join Date
    Jul 2010
    Location
    NYC
    Posts
    2,351

    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.

  22. #22
    New Member
    Join Date
    May 2012
    Posts
    4

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

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

    Bruce

  23. #23
    New Member
    Join Date
    May 2012
    Posts
    4

    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.

  24. #24
    Fanatic Member
    Join Date
    Apr 2015
    Location
    Finland
    Posts
    658

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

    Quote Originally Posted by OlsonSound View Post
    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?

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width