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

＆＃34;附件的来源。这可以是文件（由带文件名的完整文件系统路径表示）或构成附件的Outlook项目。＆＃34;

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

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

有一种有趣的方法here，其中msg文件全部保存为＆＃34; KillMe.msg＆＃34;所以如果有必要，只有一个文件以编程方式杀死或手动删除。

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

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

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

3 个答案: