VBA单独转发超过1个附加电子邮件（邮件附件）

Question

找到大量转发单个电子邮件的帖子，但这是另一个问题。我有数百封电子邮件，每封邮件包含3到8个附加的电子邮件信息（不是像PDF等常规附件）。我怎样才能获得一个宏来将每个附加的消息转发到它自己的邮件中？一直在尝试像下面的代码片段，但当然它停止在星号。感谢任何线索。

Sub ForwardEachAttachmentIndividually() 
    Dim OA As Application, OI As Outlook.Inspector, i As Long 
    Dim msgx As MailItem, msgfw As MailItem 
    Set OA = CreateObject("Outlook.Application") 
    Set OI = Application.ActiveInspector 
    Set msgx = OI.CurrentItem 
    For i = 1 To msgx.Attachments.Count 
     If Right(msgx.Attachments(i).DisplayName, 4) = ".msg" Then 
      Set msgfw = CreateItem(olMailItem) 
      msgfw.Display 
      msgfw.Attachments.Add msgx.Attachments(i) '***nggh 
      msgfw.Attachment(i).Forward 
      msgfw.Recipients.Add "zelda@foobar.com" 
      msgfw.Send 
     End If 
    Next 
End Sub 

Answer 1

下面是一个使用API发布here蛮力方法。

Sub test() 
    Dim olApp As Outlook.Application: Set olApp = Outlook.Application 
    Dim objNS As Outlook.NameSpace: Set objNS = olApp.GetNamespace("MAPI") 
    Dim olFol As Outlook.MAPIFolder: Set olFol = objNS.GetDefaultFolder(olFolderInbox) 
    Set olFol = olFol.Folders("Test Folder") 'change to suit 

    Dim msg As Outlook.MailItem, att As Outlook.Attachment 
    Set msg = olFol.Items(olFol.Items.Count) 'change to suit 

    Dim strfile As String, fmsg As Outlook.MailItem 
    For Each att In msg.Attachments 
     If att.Type = 5 Then 'check if it is of olEmbeddedItem Type 
      strfile = Environ("Temp") & "\" & att.FileName 
      att.SaveAsFile strfile 
      'Use the function to open the file 
      ShellExecute 0, "open", strfile, vbNullString, vbNullString, 0 
      'Wait until it is open 
      Do While olApp.Inspectors.Count = 0: DoEvents 
      Loop 
      'Grab the inspector 
      Set fmsg = olApp.Inspectors.Item(1).CurrentItem 
      'Forward message 
      With fmsg.Forward 
       .To = "zelda@foobar.com" 
       .Send 
      End With 
      'Close and discard inspector 
      fmsg.Close 1: Set fmsg = Nothing '1 is for olDiscard 
      'Delete the file 
      Kill strfile 
     End If 
    Next 
End Sub 

这里是功能以防万一的链接断开

Private Declare Function ShellExecute Lib "shell32.dll" Alias _ 
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _ 
    ByVal lpFile As String, ByVal lpParameters As String, _ 
    ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long 

这是经得起考验的。所以首先，我试着测试文件夹中的最新消息在我的Inbox中。
然后我们检查msg是否有olEmbeddedItem类型的附件（附件mailitem）。
请注意，您仍然需要检查msg是否为MailItem（我在测试中跳过了它）。
上面的两个答案是正确的，您需要保存该文件。
一旦保存，使用API打开它，你需要的只是抓住Inspector。
如果要用大量电子邮件重复此操作，则需要添加另一个循环。 HTH。

Answer 2

Attachments.Add Method

“附件的源，这可以是文件（通过用一个文件名的完整文件系统路径表示）或构成该附件Outlook项目”。

.msg文件是不是Outlook项目的附件，因此将.msg文件保存在临时文件夹中。

编辑2：根据Eugene的评论。答案停在上面的行。示例代码显示了如何保存msg附件，并提供了有关仅保存一个文件的想法。这不是实际的解决方案。 Edit2结束。

有一个有趣的方法here其中msg文件全部保存为“KillMe.msg”，因此如有必要，只有一个文件可通过编程方式杀死或手动删除。

编辑1：仅用于说明目的。您可能会想要使用实际的名称。请记住，您将要删除文件名中的非法字符。编辑完1

Sub SaveOlAttachments() 

Dim olFolder As MAPIFolder 
Dim olFolder2 As MAPIFolder 
Dim msg As MailItem 
Dim msg2 As MailItem 
Dim strFilePath As String 
Dim strTmpMsg As String 

'path for creating attachment msg file for stripping 
strFilePath = "C:\temp\" 
strTmpMsg = "KillMe.msg" 

'My testing done in Outlok using a "temp" folder underneath Inbox 
Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
Set olFolder2 = olFolder.Folders("Forwarded") 
Set olFolder = olFolder.Folders("Received") 

For Each msg In olFolder.Items 
    If msg.Attachments.Count > 0 Then 
     If Right$(msg.Attachments(1).FileName, 3) = "msg" Then 
      msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg 
      Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg) 
     End If 
     msg.Delete 
     msg2.Move olFolder2 
    End If 
Next 
End Sub 

Answer 3

您需要先保存附件。

Sub ForwardEachAttachmentIndividually() 
    Dim OA As Application, OI As Outlook.Inspector, i As Long 
    Dim msgx As MailItem, msgfw As MailItem 
    Set OA = CreateObject("Outlook.Application") 
    Set OI = Application.ActiveInspector 
    Set msgx = OI.CurrentItem 
    Dim strPath As String 
    For i = 1 To msgx.Attachments.Count 
     If Right(msgx.Attachments(i).DisplayName, 4) = ".msg" Then 
      Set msgfw = CreateItem(olMailItem) 
      msgfw.Display 
      strPath = "C:\Users\me\Documents\tempAtt" & msgx.Attachments(i).FileName 
      msgx.Attachments(i).SaveAsFile strPath 
      msgfw.Attachments.Add strPath 
      'msgfw.Attachments.Add msgx.Attachments(i) '***nggh 
      msgfw.Attachment(i).Forward 
      msgfw.Recipients.Add "zelda@foobar.com" 
      msgfw.Send 
     End If 
    Next 
End Sub