从 Excel 中使用 VBA 提取 Outlook 邮件正文文本
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/16074387/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Extract outlook message body text with VBA from Excel
提问by Andy
I have a huge number of Outlook .msg and Outlook .eml files saved to a shared network folder (ie outside of Outlook). I am trying to write some VBA in Excel that extracts the Subjects，Sender, CC, Receiver, SentTime, SentDate, message body text from each file and import these info to Excel cells orderly
我有大量的 Outlook .msg 和 Outlook .eml 文件保存到共享网络文件夹（即 Outlook 之外）。我正在尝试在 Excel 中编写一些 VBA，从每个文件中提取主题，发件人，抄送，收件人，SentTime，SentDate，消息正文文本并将这些信息有序导入 Excel 单元格
Subject Sender CC Receiver SentTime SentDate
主题发送者 CC 接收者 SentTime SentDate
Re:.. Mike Jane Tom 12:00:00 23 Jan 2013
回复：... Mike Jane Tom 2013 年 1 月 23 日 12:00:00
I've done a similar thing with word documents but I'm struggling to 'get at' the text in the .msg files.
我对 word 文档做了类似的事情，但我正在努力“获取” .msg 文件中的文本。
So far I have the code below. I like to think I'm on the right track at least, but I'm stuck at the line where I'm trying to set up a reference to the msg file. Any advice will be appreciated...
到目前为止，我有下面的代码。我想至少我是在正确的轨道上，但我被困在我试图设置对 msg 文件的引用的行中。任何建议将被认真考虑...
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Set MyOutlook = New Outlook.Application
Set MyMail =
Dim FileContents As String
FileContents = MyMail.Body
Regards
问候
回答by Zack Kay
so I've been able to get it working with .msg files saved outside of outlook. However, as I don't have access to Outlook Express I have no way of saving any .eml files at the moment. Here's a Sub I've come up with that will insert Subject,Sender,CC,To, and SendOn into an excel worksheet starting at row 2 column 1 (assuming a header row at row 1):
所以我已经能够让它与保存在 Outlook 之外的 .msg 文件一起工作。但是，由于我无法访问 Outlook Express，我目前无法保存任何 .eml 文件。这是我想出的一个子程序，它将主题、发件人、抄送、收件人和发送到从第 2 行第 1 列开始的 excel 工作表中（假设第 1 行有标题行）：
Sub GetMailInfo(Path As String)
Dim MyOutlook As Outlook.Application
Dim msg As Outlook.MailItem
Dim x As Namespace
Set MyOutlook = New Outlook.Application
Set x = MyOutlook.GetNamespace("MAPI")
FileList = GetFileList(Path + "*.msg")
row = 1
While row <= UBound(FileList)
Set msg = x.OpenSharedItem(Path + FileList(row))
Cells(row + 1, 1) = msg.Subject
Cells(row + 1, 2) = msg.Sender
Cells(row + 1, 3) = msg.CC
Cells(row + 1, 4) = msg.To
Cells(row + 1, 5) = msg.SentOn
row = row + 1
Wend
End Sub
which uses the GetFileList function as defined below (thanks to spreadsheetpage.com)
它使用如下定义的 GetFileList 函数（感谢电子表格页面.com ）
Function GetFileList(FileSpec As String) As Variant
' Taken from http://spreadsheetpage.com/index.php/tip/getting_a_list_of_file_names_using_vba/
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Should be fairly straightforward, let me know if you need any more explanation.
应该相当简单，如果您需要更多解释，请告诉我。
Edit: You'll also have to add a reference to the outlook library
编辑：您还必须添加对 Outlook 库的引用
HTH!
哼！
Z
Z
回答by Marcelo - developing for fun
' The code below will be able to work with almost all messages from Outlook, ' except and I don′t know why if you are working with messages generated by ' Exchange Server such as "Mail Delivery System". It does looks like it is not a ' really message at this point. If you try to read it the object "olItem" is 'always Empty. However if you get this alert "Mail Delivery System" and forward 'to yourself and then try to read it, it does work fine. Don′t ask me 'why because I have no idea. I just think that this "Mail Delivery System" 'at first time it is an alert and not a message, also the icon does change, it 'is not an envelop icon but a delivery with success or not icon. if you have ' any idea how to handle it, please adivise
' 下面的代码将能够处理几乎所有来自 Outlook 的邮件，' 除了我不知道为什么您正在处理由 ' Exchange Server 生成的邮件，例如“邮件传递系统”。在这一点上，它看起来确实不是一个 ' 真正的消息。如果您尝试读取它，则对象“olItem”为“始终为空”。但是，如果您收到此警报“邮件传递系统”并转发给您自己，然后尝试阅读它，它确实可以正常工作。不要问我为什么，因为我不知道。我只是认为这个“邮件传递系统”“第一次是警报而不是消息，图标也会改变，它不是信封图标，而是成功与否的传递图标。如果您有任何想法如何处理，请指教
Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox).Folders("mFolder")
On Error Resume Next
i = 5
cont1 = 0
Sheet2.Cells(4, 1) = "Sender"
Sheet2.Cells(4, 2) = "Subject"
Sheet2.Cells(4, 3) = "Received"
Sheet2.Cells(4, 4) = "Recepient"
Sheet2.Cells(4, 5) = "Unread?"
Sheet2.Cells(4, 6) = "Link to Report"
For Each olItem In olInbox.Items
myText = olItem.Subject
myTokens = Split(myText, ")", 5)
myText = Mid(myTokens(0), 38, Len(myTokens(0)))
myText = RTrim(myText)
myText = LTrim(myText)
myText = myText & ")"
myLink = ""
myArray = Split(olItem.Body, vbCrLf)
For a = LBound(myArray) To UBound(myArray)
If a = 4 Then
myLink = myArray(a)
myLink = Mid(myLink, 7, Len(myLink))
End If
Next a
Sheet2.Cells(i, 1) = olItem.SenderName
Sheet2.Cells(i, 2) = myText
Sheet2.Cells(i, 3) = Format(olItem.ReceivedTime, "Short Date")
Sheet2.Cells(i, 4) = olItem.ReceivedByName
Sheet2.Cells(i, 5) = olItem.UnRead
Sheet2.Cells(i, 6) = myLink
olItem.UnRead = False
i = i + 1
Next
回答by David Zemens
Assuming you know, or can compute the full filename & path for the .msg :
假设您知道或可以计算 .msg 的完整文件名和路径：
Dim fName as String
fName = "C:\example email.msg"
Set MyMail = MyOutlook.CreateItemFromTemplate(fName)`
