Is there a Special Method for extracting PKZip files with VBA?

Question

I'm attempting to use a fairly standard method for pulling emails from Outlook and then extracting Zip files. The File names and the folder locations are correct. I wonder if PKZip files (our corporate standard for Zip files) requires a special technique? Here's my code so far... It works perfectly up to the point where files are extracted from the Zip files where it fails. (oApp.Namespace(fDest).CopyHere oApp.Namespace(fDest & Fname).Items)

Sub SaveAttachments()
    Dim ol As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fol As Outlook.Folder
    Dim i As Object
    Dim mi As Outlook.MailItem
    Dim at As Outlook.Attachment
    Dim Inbox As MAPIFolder
    Dim strDate As String
    Dim oApp As Object
    Dim fDest As String
    Dim fZip As String
               
    strDate = InputBox("Enter Date in format dd-Mmm-yyyy", "User Date", Format(Now(), "dd-Mmm-yyyy"))
       
    Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
    Set fol = ns.Folders("GCMNamLogs").Folders("Inbox")
    
    fDest = "C:\Users\jb76991\Desktop\0_SWPA 50011 CORP Violations\"
        
    For Each i In fol.Items.Restrict("@SQL=urn:schemas:httpmail:subject LIKE '%" & strDate & "%'")
        
        If i.Class = olMail Then
            Set mi = i
            For Each at In mi.Attachments
                If InStr(at.Filename, ".zip") > 0 Then
                    If InStr(mi.Subject, "Daily SWPA swpaViolRPT REPORT for DOMAIN:CORP") > 0 Then
                        'Set oApp = CreateObject("Shell.Application")
                        FileNameFolder = fDest
                        Fname = at.Filename
                        at.SaveAsFile fDest & Fname
                        Set oApp = CreateObject("Shell.Application")
                        Debug.Print fDest & Fname
                        oApp.Namespace(fDest).CopyHere oApp.Namespace(fDest & Fname).Items
                        Application.Wait (Now + TimeValue("0:00:02"))
                    End If
                    If InStr(mi.Subject, "Daily SWPA swpaViolRPT REPORT for DOMAIN:INFRA") > 0 Then
                        Set oApp = CreateObject("Shell.Application")
                        FileNameFolder = fDest
                        Fname = at.Filename
                        at.SaveAsFile fDest & Fname
                        Debug.Print fDest & Fname
                        oApp.Namespace(fDest).CopyHere oApp.Namespace(fDest & Fname).Items
                        Application.Wait (Now + TimeValue("0:00:01"))
                    End If
                    If InStr(mi.Subject, "Daily SWPA swpaSumRPT REPORT for DOMAIN:CORP") > 0 Then
                        Set oApp = CreateObject("Shell.Application")
                        FileNameFolder = fDest
                        Fname = at.Filename
                        at.SaveAsFile fDest & Fname
                        Debug.Print fDest & Fname
                        oApp.Namespace(fDest).CopyHere oApp.Namespace(fDest & Fname).Items
                        Application.Wait (Now + TimeValue("0:00:01"))
                    End If
                    If InStr(mi.Subject, "Daily SWPA swpaSumRPT REPORT for DOMAIN:INFRA") > 0 Then
                        Set oApp = CreateObject("Shell.Application")
                        FileNameFolder = fDest
                        Fname = at.Filename
                        at.SaveAsFile fDest & Fname
                        Debug.Print fDest & Fname
                        oApp.Namespace(fDest).CopyHere oApp.Namespace(fDest & Fname).Items
                        Application.Wait (Now + TimeValue("0:00:01"))
                    End If

                End If
            Next at
        End If
    Next i
    MsgBox ("Done")
    
End Sub

To achieve what I think you're trying to achieve, first you need to extract the attachment (the zip file) from the Outlook message (this might be helpful for that step: https://stackoverflow.com/questions/15531093/save-attachments-to-a-folder-and-rename-them), then you need to extract the files from zip file. This code is not doing either of those things as far as I can tell. When you say "it fails", can you be a bit more specific? Do you get an error message? — Nicholas Hunter, Apr 05 '21 at 14:59
@Nicholas Thank you for taking a look. The error is Run-Time Error '91' Object variable or With block variable not set. The code currently pulls the email attachments and saves them to "C:\Users\jb76991\Desktop\0_SWPA 50011 CORP Violations". If you comment out the extraction part of the code, all attachments are pulled and saved there. — CaptMAZing, Apr 05 '21 at 15:14
OK Sorry I misspoke. I see where the attachments are saved to the network folder. But I am pretty sure that oApp.Namespace(fDest).CopyHere oApp.Namespace(fDest & Fname).Items is not going to extract files from the zip file. It looks like this command copies items from one Outlook folder to another. https://docs.microsoft.com/en-us/windows/win32/shell/folder-copyhere — Nicholas Hunter, Apr 05 '21 at 15:32
There might be an external library you can use to extract files from a zip file. I used have to use the Shell command. It worked but it was hella clunky. — Nicholas Hunter, Apr 05 '21 at 15:34
Check out my `UnZip` function found [here](https://github.com/GustavBrock/VBA.Compress). — Gustav, Apr 05 '21 at 16:04
@NicholasHunter I see that one of my Shell commands is commented out, but uncommenting does not fix the issue. I've seen here and other places where files are extracted to the network: [https://stackoverflow.com/questions/35717193/unzip-folder-with-files-to-the-chosen-location], so I don't believe that part of the code is an issue. I would definitely appreciate some insights. — CaptMAZing, Apr 05 '21 at 16:07
I'm stumped. Did you try putting a breakpoint on the line that's giving you the error and checking all the variables have the proper values? That's all I can suggest. — Nicholas Hunter, Apr 05 '21 at 17:10
Any values passed in as parameters to Shell methods should be declared as `Variant`, not as `String`. String values do not play well with Shell — Tim Williams, Apr 05 '21 at 21:28

score 0 · Answer 1 · answered Apr 05 '21 at 22:45

The string/variant is the fix, but you'd also benefit from reducing the repetition in the code

(untested)

Sub SaveAttachments()
    Dim ol As Outlook.Application
    Dim ns As Outlook.Namespace
    Dim fol As Outlook.Folder
    Dim i As Object
    Dim mi As Outlook.MailItem
    Dim at As Outlook.Attachment
    Dim Inbox As MAPIFolder
    Dim strDate As String
    Dim fDest As Variant, FName As Variant, e, arrZips
    
    strDate = InputBox("Enter Date in format dd-Mmm-yyyy", "User Date", Format(Now(), "dd-Mmm-yyyy"))
       
    Set ol = New Outlook.Application
    Set ns = ol.GetNamespace("MAPI")
    Set fol = ns.Folders("GCMNamLogs").Folders("Inbox")
    
    arrZips = Array("Daily SWPA swpaViolRPT REPORT for DOMAIN:CORP", _
                    "Daily SWPA swpaViolRPT REPORT for DOMAIN:INFRA", _
                    "Daily SWPA swpaSumRPT REPORT for DOMAIN:CORP", _
                    "Daily SWPA swpaSumRPT REPORT for DOMAIN:INFRA")
    
    fDest = "C:\Users\jb76991\Desktop\0_SWPA 50011 CORP Violations\"
        
    For Each i In fol.items.Restrict("@SQL=urn:schemas:httpmail:subject LIKE '%" & strDate & "%'")
        If i.Class = olMail Then
            Set mi = i
            For Each at In mi.Attachments
                FName = at.Filename
                If InStr(FName, ".zip") > 0 Then
                    For Each e In arrZips
                        If InStr(mi.Subject, e) > 0 Then
                            at.SaveAsFile fDest & FName
                            ExtractZip fDest & FName, fDest, 2
                            Exit For
                        End If
                    Next e
                End If
            Next at
        End If
    Next i
    MsgBox ("Done")
End Sub

Sub ExtractZip(ZipPath, DestFolder, Optional waitsecs As Long = 0)
    Debug.Print "Extracting '" & ZipPath & "' to '" & DestFolder & "'"
    With CreateObject("Shell.Application")
        .Namespace(DestFolder).copyhere .Namespace(ZipPath).items
    End With
    If waitsecs > 0 Then Application.Wait Now + waitsecs / (24 * 60 * 60)
End Sub

Is there a Special Method for extracting PKZip files with VBA?

1 Answers1