用VBA解压缩PKZip文件有什么特别的方法吗？

Question

我正在尝试使用一种相当标准的方法从Outlook中提取电子邮件，然后提取Zip文件。文件名和文件夹位置正确。我想知道PKZip文件(我们公司的Zip文件标准)是否需要特殊的技术？这是我到目前为止的代码。它工作得很好，直到从Zip文件中提取文件失败为止。( 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

字符串/变量是修复方法，但您也可以从减少代码中的重复中获益

(未测试)

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