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

我收到很多包含.msg附件的电子邮件。我通常必须手动打开电子邮件，然后打开.msg附件以转到附加的.pdf文件。我经常以这种格式收到200多封电子邮件，需要一些时间才能打印所有PDF文件。我设法拼凑下面的代码（有很多的帮助从在线论坛）节省作为电子邮件发送的电子邮件的附件（即MSG）

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附件），然后运行该脚本。我遇到的问题是，当附件具有相同的名称，即AT0001时，脚本将仅提取一个附件并将所有其他附件保留。谁能帮忙？谢谢

来源

2013-05-17 Alan

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

来源

2013-05-17 16:32:49

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

回答

相关问题