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