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

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

Answer 1

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