下载多个电子邮件附件并重命名它们

Question

我每天都会收到来自超过 10 家不同商店的电子邮件。每封电子邮件通常有多个附件。我将每封电子邮件的附件下载到各自的本地子目录中。

我使用在网上找到的代码下载附件。我将脚本与规则相结合，以便附件下载到各自的本地文件夹。

问题：假设商店 1 每天发送一个名为 ABC.xlsx 的文件。我的规则/脚本按时间倒序运行，因此脚本一个接一个地遍历每封邮件，每个文件都会替换最新的文件，直到我得到最早的文件。

我需要我的脚本来保存最新文件，或者更恰当地说，更新文件名并将当前日期附加到现有文件名。

Public Sub SaveAttachmentsToDisk_St10(MItem As Outlook.MailItem)
    Dim oAttachment As Outlook.Attachment
    Dim sSaveFolder As String
    sSaveFolder = "H:\Folder1\Projects\Online\Data\Store 10\MC\"
    For Each oAttachment In MItem.Attachments
        oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
    Next
End Sub

Answer 1

您可以使用ReceivedTime 从邮件中获取日期。这将返回一个日期，将其与 Format 函数一起使用来创建一个附加到文件名的后缀。我建议将日期设置为 YYYYMMDD，这有助于对文件名进行排序。

For Each oAttachment In MItem.Attachments
    Dim filename As String, p As Long, suffix As String
    filename = oAttachment.DisplayName
    suffix = "_" & Format(MItem.ReceivedTime, "YYYYMMDD_HHNN")
    ' Now add the suffix before the file extension
    p = InStrRev(filename, ".")    ' Find dot to separate file extension
    If p > 0 Then
        filename = Left(filename, p - 1) & suffix & Mid(filename, p)
    Else
        filename = filename & suffix
    End If
    oAttachment.SaveAsFile sSaveFolder & filename
Next