Question

我收到了很多包含.msg附件的电子邮件。我通常必须手动打开电子邮件，然后打开.msg附件以获取附加的.pdf文件。我经常以这种格式收到200多封电子邮件，打印所有PDF文件需要一些时间。我设法将下面的代码放在一起（在网上论坛上提供了很多帮助）

Sub SaveOlAttachments()

Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim msg2 As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strTmpMsg As String
Dim fsSaveFolder As String

fsSaveFolder = "C:\Users\nicholson.a.9\Desktop\Invoices to Print\"

strFilePath = "C:\temp\"
strTmpMsg = "KillMe.msg"

Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("MSG Attachments")
i = 0
If olFolder Is Nothing Then Exit Sub
For Each msg In olFolder.Items

    If msg.Attachments.Count > 0 Then
    While msg.Attachments.Count > 0
    bflag = False
        If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
            bflag = True
            msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
            Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
        End If
        If bflag Then
        i = i + 1
            sSavePathFS = fsSaveFolder & "\" & i & " - " & msg2.Attachments(1).FileName
            msg2.Attachments(1).SaveAsFile sSavePathFS
            msg2.Delete
        Else
            sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
            msg.Attachments(1).SaveAsFile sSavePathFS
        End If
        msg.Attachments(1).Delete
        Wend
        msg.Delete
    End If
Next
End Sub

代码有效，如果我收到带有msg附件的电子邮件，我会复制该电子邮件并将其粘贴到我的收件箱（MSG附件）下面的子文件夹中，然后运行该脚本。我遇到的问题是当附件具有相同的名称，即AT0001时，脚本将只提取一个附件并保留所有其他附件。有人可以帮忙吗？感谢

Answer 1

您可能会保存所有附件，但最新的附件会胜出并覆盖旧附件。您需要检查文件是否已存在并使用唯一的文件名，或者保存附件并在保存下一个附件之前对其进行处理。

节省来自作为电子邮件发送的电子邮件的附件（即MSG）

1 个答案: