Savings Attachments from an email that was sent as an Email (i.e. MSG)
我收到很多包含 .msg 附件的电子邮件。我通常必须手动打开电子邮件，然后打开 .msg 附件以获取附加的 .pdf 文件。我经常收到超过 200 封这种格式的电子邮件，打印所有 PDF 文件需要一些时间。我设法将以下代码放在一起(在在线论坛的大量帮助下)
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | 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\ icholson.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，脚本只会提取一个附件并保留所有其他附件。任何人都可以帮忙吗？谢谢
您可能会保存所有附件，但最新的会胜出并覆盖旧的。
您需要检查文件是否已经存在并使用唯一的文件名，或者保存附件并在保存下一个附件之前对其进行处理。