Question

每天都有一封电子邮件，其中包含两个具有相同名称的附件。我要求将两个附件都保存到指定的位置，但是其中一个覆盖另一个。

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Coronation(item As Outlook.MailItem)

    Dim object_attachment As Outlook.Attachment
    Dim saveFolder As String
    Dim today As String

    today = Format(Date - 1, "ddmmyy")

    'Folder save location
    saveFolder = "C:\Users\SChogle\Documents\Projects\VBA Projects\Email Save Collection\Drop Files"

    For Each object_attachment In item.Attachments
        If InStr(object_attachment.DisplayName, ".csv") Or InStr(object_attachment.DisplayName, ".xlsx") Or InStr(object_attachment.DisplayName, ".xls") Then
            object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName & Format(Now(), "ddmmyyhhmmss")
        End If
        Sleep 1000
    Next

End Sub

我希望两个附件都可以保存。

Answer 1

尝试一下：

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub test()

    Dim object_attachment As Outlook.Attachment
    Dim saveFolder As String
    Dim today As String

    today = Format(Date - 1, "ddmmyy")

    'Folder save location
    saveFolder = "C:\Users\SChogle\Documents\Projects\VBA Projects\Email Save Collection\Drop Files"

    For Each object_attachment In item.Attachments
        If InStr(object_attachment.DisplayName, ".csv") Or InStr(object_attachment.DisplayName, ".xlsx") Or InStr(object_attachment.DisplayName, ".xls") Then
            object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName & Format(Now(), "ddmmyyhhmmss")
        End If
        Sleep 1000
    Next

End Sub

我还对您的代码进行了缩进，以使代码更具可读性，并且不会因未关闭实例而提示错误。如果您不知道如何缩进，可以使用Mathieu

中的RubberDuck

在具有相同名称的同一电子邮件中下载两个附件

1 个答案: