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

Question

发现很多帖子可以转发一封电子邮件，但这是另一个问题。我有数百封电子邮件，每封包含 3 到 8 封附加电子邮件（不是 PDF 等常规附件）。我怎样才能获得一个宏来转发每个附加的邮件在它自己的个人电子邮件中？一直在尝试像下面的 sn-p 这样的代码，但当然它停在星号处。感谢任何线索。

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 的Test Folder 中尝试了最新消息。
然后我们检查msg 是否有olEmbeddedItem 类型的附件（附加邮件项）。
请注意，您仍然需要检查msg 是否为MailItem 类型（我在测试中跳过了它）。
上面的两个答案是正确的，您需要保存文件。
保存后，打开它使用API，您只需抓住Inspector。
如果您要通过大量电子邮件重复此操作，则需要添加另一个循环。 HTH。

Answer 2

您需要先保存附件。

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

Answer 3

Attachments.Add Method

“附件的来源。这可以是一个文件（由带有文件名的完整文件系统路径表示）或构成附件的 Outlook 项目。”

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

Edit2：基于 Eugene 的评论。答案停在上面一行。示例代码展示了如何保存一个 msg 附件，并给出了只保存一个文件的想法。这不是实际的解决方案。编辑2结束。

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

Edit1：仅用于说明目的。您可能希望使用实际名称。请记住，您需要删除文件名中的非法字符。编辑结束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