VBA 单独转发超过 1 封附加电子邮件(邮件附件)

VBA to individually forward more than 1 attached emails (message attachments)

找到很多转发一封电子邮件的帖子,但这是另一个问题。我有数百封电子邮件,每封包含 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

Attachments.Add Method

"The source of the attachment. This can be a file (represented by the full file system path with a file name) or an Outlook item that constitutes the attachment."

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

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

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

Edit1:仅供参考。您可能希望使用实际名称。请记住,您需要删除文件名中的非法字符。 Edit1 结束

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

您需要先保存附件。

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

下面是使用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

这是函数,以防 link 损坏

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 是否有 [=15] 的附件=]类型(附邮件项目)。
请注意,您仍然需要检查 msg 是否为 MailItem 类型(我在测试中跳过了它)。
上面的两个答案是正确的,您需要保存文件。
保存后,使用 API 打开它,你需要的只是抓住 Inspector
如果你要重复很多,你需要添加另一个循环电子邮件。 HTH.