我收到很多包含 .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,脚本只会提取一个附件并保留所有其他附件。任何人都可以帮忙吗?谢谢