使用 VBA 从 Excel 中提取 Outlook 邮件正文文本

Question

我有大量的 Outlook .msg 和 Outlook .eml 文件保存到共享网络文件夹（即 Outlook 外部）。我正在尝试在 Excel 中编写一些 VBA，从每个文件中提取主题，发件人、抄送、收件人、发送时间、发送日期、邮件正文文本并将这些信息按顺序导入 Excel 单元格

主题发件人抄送收件人发送时间发送日期

回复：.. Mike Jane Tom 2013 年 1 月 23 日 12:00:00

我对 word 文档做了类似的事情，但我很难“理解” .msg 文件中的文本。

到目前为止，我有下面的代码。我喜欢认为我至少在正确的轨道上，但我被困在我试图设置对 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

问候

Answer 1

假设您知道，或者可以计算 .msg 的完整文件名和路径：

Dim fName as String
fName = "C:\example email.msg"

Set MyMail = MyOutlook.CreateItemFromTemplate(fName)`

Answer 2

所以我已经能够使用保存在 Outlook 之外的 .msg 文件。但是，由于我无法访问 Outlook Express，我目前无法保存任何 .eml 文件。这是我想出的一个 Sub，它将 Subject、Sender、CC、To 和 SendOn 插入到 Excel 工作表中，从第 2 行第 1 列开始（假设第 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

它使用如下定义的 GetFileList 函数 （感谢spreadsheetpage.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

应该相当简单，如果您需要更多解释，请告诉我。

编辑：您还必须添加对 Outlook 库的引用

HTH！

Z

Answer 3

' 下面的代码将能够处理来自 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