首页 文章

使用Excel中的VBA提取Outlook消息正文文本

提问于
浏览 次
0

我有大量的Outlook .msg和Outlook .eml文件保存到共享网络文件夹（即Outlook之外） . 我试图在Excel中编写一些VBA，从每个文件中提取主题，发件人，CC，接收者，SentTime，SentDate，邮件正文文本，并将这些信息有序地导入Excel单元格

主题发件人CC Receiver SentTime SentDate

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

我用word文档做了类似的事情，但我正在努力“了解”.msg文件中的文本 .

到目前为止，我有以下代码 . 我喜欢认为我至少在正确的轨道上，但我仍然在我试图 Build 对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

问候

vba excel-vba outlook-vba excel

3 回答

  • 3

    所以我已经能够使用保存在outlook之外的.msg文件 . 但是，由于我无法访问Outlook Express，因此目前无法保存任何.eml文件 . 这是我想出的一个Sub，它会将Subject，Sender，CC，To和SendOn插入到第2行第1列开始的excel工作表中（假设第1行有 Headers 行）：

    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！

    ž

    回复于
  • 0

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

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

Set MyMail = MyOutlook.CreateItemFromTemplate(fName)`
    回复于
  • 0

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

相关问题