在outlook中使用VBA自动将Zip FLODER下载到计算机上

我想在Outlook中使用VBA下载一系列zip文件。我已经编码到它成功地通过我的子文件夹中的所有电子邮件并下载其中的任何附件的程度。它在excel附件上进行了测试，效果良好

但是，我尝试下载的文件是Zip文件

当我在包含拉链的电子邮件上运行脚本时，我得到了一个奇怪的文件

奇怪结果的屏幕截图

下面是我的代码。 请帮忙

Sub GetAttachments()
    'declaring an error statement
    On Error GoTo GetAttachments_err
        
    'Declaring my variables
    'NameSpace: Obj tha gives you access to all outlooks folders
    Dim ns As NameSpace
    'This will refer to a mail folder
    Dim Inbox As MAPIFolder
    Dim Item As Object
    'Attachment we are looking for
    Dim Atmt As Attachment
    'Used to create a name and save path for each attachment as it is saved.
    Dim FileName As String
    'Counter to log the progress of the macro
    Dim i As Integer
    'to look in the subfliter i am filtering all the exception reports to
    Dim SubFolder As MAPIFolder
    
    'setting the variables
    Set ns = GetNamespace("MAPI")
    Set Inbox = ns.GetDefaultFolder(olFolderInbox)
    Set SubFolder = Inbox.Folders("Post-Algo: Mapping Exception Reports")
    i = 0
    
    'if statment to check if there are any messages in the inbox folder and abandon search if there are none.
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in the Inbox.", vbInformation, _
           "Nothing Found"
        Exit Sub
    End If
    
    'starts looking for attachments if there are items in the file
    If SubFolder.Items.Count > 0 Then
        'looks at each item in the inbox
        For Each Item In SubFolder.Items
            'looks at each attachment
            For Each Atmt In Item.Attachments
                'creates a file name by appending the fiel name
                'remember to change the path to the desired location and to creat the file path.
                FileName = "H:\exceptionDownload\" & Item.Subject & " " & i & Atmt.FileName
                'saves the file under that name.
                Atmt.SaveAsFile FileName
                'increment the log variable.
                i = i + 1
            Next Atmt
        Next Item
    End If
    
    
    If i > 0 Then
        MsgBox "I found " & i & " attached files." _
           & vbCrLf & "I have saved them into the H:\exceptionDownload\." _
           & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
    Else
        MsgBox "I didn't find any attached files in your mail.", vbInformation, _
        "Finished!"
    End If
    
' Clear the values of the variables
GetAttachments_exit:
   Set Atmt = Nothing
   Set Item = Nothing
   Set ns = Nothing
   Exit Sub

'error handling
GetAttachments_err:
   MsgBox "An unexpected error has occurred." _
      & vbCrLf & "Please note and report the following information." _
      & vbCrLf & "Macro Name: GetAttachments" _
      & vbCrLf & "Error Number: " & Err.Number _
      & vbCrLf & "Error Description: " & Err.Description _
      , vbCritical, "Error!"
   Resume GetAttachments_exit



End Sub

---

我会尝试检查您想要的特定扩展，而忽略所有其他扩展。您有一个下载附件的过程，但您必须排除附件中未显示的某些内容，因为其他对象（如嵌入的图像）也作为附件处理

试试这个：

For Each Item In SubFolder.Items
    For Each Atmt In Item.Attachments
        If right(Atmt.FileName, 4) = ".zip" Then
            FileName = "H:\exceptionDownload\" & Item.Subject & " " & i & Atmt.FileName
            Atmt.SaveAsFile FileName
            'increment the log variable.
            i = i + 1
        End If
    Next Atmt
Next Item

---

这将排除电子邮件中无关的“隐藏”对象。

以下是我使用的工作代码。这可能比你想要的多一点，但希望你能适应

它处理压缩文件和非压缩文件，并丢弃您想要忽略的扩展名。它还可以自动下载任何太大而无法通过电子邮件发送的基于云的附件。在提取数据之前，它会将压缩后的附件保存到临时文件夹中。保存和解压缩的附件也会被路由到相应的文件夹

保存附件方法：这是基于Outlook规则运行的主要方法。附件的目标文件夹是根据电子邮件的主题（案例陈述）设置的。在示例代码中，如果主题为“Test”，则它不会下载附件，而是搜索文本内超链接并下载基于云的附件。如果附件是一个.zip文件，那么它会将其下载到一个临时文件夹并调用“Unzip方法”

解压方法：此方法接收解压后的文件并将其解压到目标文件夹

IsInArray函数：查看附件的扩展是否在跳过的附件（如jpg）数组中。返回True或False

启动URL方法：搜索电子邮件中的每个单词，并查找与基于云的附件的定义URL匹配的URL（域名模糊匹配）。使用当前发件人、日期和时间命名文件

DownloadFileFromWeb功能：启动基于云的附件的URL（由LaunchURL方法定义），并将其保存到相应的文件夹中

Public Sub SaveAttachments(Item As Outlook.MailItem)

Dim objAttachments As Outlook.Attachments
Dim lngCount, i As Long
Dim strFile, sFileType, destinationFolder, destinationFolderPath, username, subject, rootFolderPath, tempFolderPath, tempFolder, ext, sender As String
Dim isZipped As Boolean
Dim skippedExts() As String


'Gets username
    username = VBA.Interaction.Environ$("UserName")

'Sets the root folder ************************* EDIT THIS *******************************
    rootFolderPath = "C:\Users\" & username & "\Box Sync\Save and Unzip Test\"


'Sets the temp folder Name used to hold the zipped downloads ************************* EDIT THIS *******************************
    tempFolder = "Zip Files"

'List the extentions that you want to skip delimited by a bar '|' ************************* EDIT THIS *******************************
    skippedExts = Split("jpg|jpeg|png|gif", "|")



'Sets the destination folder is set to match it's appropiate data sources ************************* EDIT THIS *******************************
    Select Case Item.subject

        Case "Test"
            destinationFolder = "TestFolder"

         Case Else
            destinationFolder = "DefaultFolder"

    End Select

'********************************************************************************************************************************************

'Sets the root path for non-zipped files
    destinationFolderPath = rootFolderPath & destinationFolder & "\"

'Sets the temp folder path for the zip files
    tempFolderPath = rootFolderPath & tempFolderName & "\"

'Launchs another method if the sender is Convetro to download the file from the URL
    If destinationFolder = "Test" Then
        Call LaunchURL(Item, destinationFolderPath)
        Exit Sub
    End If


If Item.Attachments.Count > 0 Then

    Set objAttachments = Item.Attachments

    'Counts the number of attachments
        lngCount = objAttachments.Count


    For i = lngCount To 1 Step -1

        'Resets the Boolean
            isZipped = False

        'Get the file name of the attachment
            strFile = objAttachments.Item(i).fileName

        'Gets the file extention
            ext = Split(strFile, ".")(UBound(Split(strFile, ".")))

        'If the attachment is an image, then skip it (calls the function to check whether the ext is in the array 'skippedExts')
            If IsInArray(ext, skippedExts) = True Then
                GoTo NextAttachment
            End If

        'If the attachment is a zip, then the path is set to a temp folder.
            If ext = "zip" Then
                strFolderpath = tempFolderPath
                isZipped = True
            Else
                strFolderpath = destinationFolderPath
            End If

        'Combine with the path to the folder
            strFile = strFolderpath & strFile

        'Save the attachment as a file
            objAttachments.Item(i).SaveAsFile strFile

        'Calls the Unzip method to unzip the saved attachment
        If isZipped = True Then
            Call Unzip(strFile, destinationFolderPath)
        End If


NextAttachment:
    Next i
End If


End Sub


Sub Unzip(ByVal strFile As Variant, ByVal destinationFolderPath As String)

Dim FSO, oApp As Object
Dim destinationPath As Variant

'Sets the folderpath string as a variant
    destinationPath = destinationFolderPath

'Extract the files into the newly created folder
    Set oApp = CreateObject("Shell.Application")
    oApp.NameSpace(destinationPath).CopyHere oApp.NameSpace(strFile).Items


    On Error Resume Next
    Set FSO = CreateObject("scripting.filesystemobject")
    FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True

End Sub


    Private Function IsInArray(ByVal stringToBeFound As String, ByVal arr As Variant) As Boolean
      IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
    End Function

Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long


Sub LaunchURL(itm As MailItem, ByVal destinationPath As String)

    Dim bodyString As String
    Dim bodyStringSplitLine
    Dim bodyStringSplitWord
    Dim splitLine
    Dim splitWord
    Dim fileName, URL As String

'Defines 'bodyString' as the body of text in the email
    bodyString = itm.Body

'Breaks the body copy into multiple lines
    bodyStringSplitLine = Split(bodyString, vbCrLf)


'Sets the desired name of the file ************ Edit here *******************
    fileName = "MySender--" & Format(Now(), "yyyy-mm-dd--hh-mm-ss") & ".csv"


'Loop to run through ever line in the email and split it into a bunch of words
    For Each splitLine In bodyStringSplitLine
        bodyStringSplitWord = Split(splitLine, " ")


        'Loop to run through ever word in the line, and test whether it's the link we are looking for
        For Each splitWord In bodyStringSplitWord

            'A test to see whther the word is the URL link that we are looking for *************************** Edit here **********************************
            If Left(splitWord, 34) = "<https://myURLtobedownloaded.com/" Then

                'Deletes the "<>" from the URL
                URL = splitWord
                URL = Replace(Replace(URL, "<", ""), ">", "")

                'If the word is the URL link, then it calls the function DownloadFileFromWeb and saves it to the destination folder
                Call DownloadFileFromWeb(URL, destinationPath & fileName)

            End If
        Next

    Next

    Set itm = Nothing

End Function


Private Function DownloadFileFromWeb(URL As String, SavePath As String) As Boolean
Dim MyLink As String
Dim Ret As Long

'First delete the file from cache:
    DeleteUrlCacheEntry URL

'Download the file and return result:
    DownloadFileFromWeb = False
    Ret = URLDownloadToFile(0, URL, SavePath, 0, 0)
    DoEvents

    If Ret = 0 Then DownloadFileFromWeb = True
End Function

Public子存储附件（项目为Outlook.MailItem）
作为Outlook.Attachments的Dim OBJAAttachments
暗计数，我只要
Dim strFile、sFileType、destinationFolder、destinationFolderPath、用户名、主题、rootFolderPath、tempFolderPath、tempFolder、ext、发件人作为字符串
Dim压缩为布尔值
Dim skippedExts（）作为字符串
'获取用户名
用户名=VBA.Interaction.Environ$（“用户名”）
'设置根文件夹***************************编辑此文件夹*******************************
rootFolderPath=“C:\Users\”&username&“\Box Sync\Save and Unzip Test\”
'设置用于保存压缩下载的临时文件夹名称***************************编辑此文件*******************************
tempFolder=“Zip文件”
'列出要跳过的扩展名，扩展名由一个条分隔'|'*********************************编辑此扩展名*******************************
skippedExts=Split（“jpg | jpeg | png | gif”，“|”）
'将目标文件夹设置为与其相应的数据源相匹配****************************编辑此*******************************
选择Case Item.subject
案例“测试”
destinationFolder=“TestFolder”
其他情况
destinationFolder=“DefaultFolder”
结束选择
'********************************************************************************************************************************************
'设置非压缩文件的根路径
destinationFolderPath=rootFolderPath&destinationFolder&“\”
'设置zip文件的临时文件夹路径
tempFolderPath=rootFolderPath&tempFolderName&“\”
'如果发件人正在转换从URL下载文件，则启动另一个方法
如果destinationFolder=“Test”，则
调用启动URL（项，destinationFolderPath）
出口接头
如果结束
如果Item.Attachments.Count>0，则
Set objAttachments=Item.Attachments
'统计附件的数量
lngCount=objAttachments.Count
对于i=lngCount到1步骤-1
'重置布尔值
isZipped=False
'获取附件的文件名
strFile=objAttachments.Item（i）.fileName
'获取文件扩展名
ext=拆分（strFile，“.”）（UBound（拆分（strFile，“.”））
'如果附件是图像，则跳过它（调用函数检查ext是否在数组'skippedExts'中）
如果IsInArray（ext，skippedExts）=True，则
转到下一站
如果结束
'如果附件是zip，则路径设置为临时文件夹。
如果ext=“zip”，则
strFolderpath=tempFolderPath
isZipped=True
其他的
strFolderpath=destinationFolderPath
如果结束
'与文件夹的路径合并
strFile=strFolderpath&strFile
'将附件另存为文件
objAttachments.Item（i）.SaveAsFile strFile
'调用解压方法来解压保存的附件
如果isZipped=True，则
调用解压（strFile，destinationFolderPath）
如果结束
下一站：
接下来我
如果结束
端接头
子解压缩（ByVal strFile作为变量，ByVal destinationFolderPath作为字符串）
Dim FSO，oApp作为对象
Dim destinationPath作为变量
'将folderpath字符串设置为变量
destinationPath=destinationFolderPath
'将文件解压缩到