Extract outlook message body text with VBA from Ex

Question

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

Subject Sender CC Receiver SentTime SentDate

Re:.. Mike Jane Tom 12:00:00 23 Jan 2013

I've done a similar thing with word documents but I'm struggling to 'get at' the text in the .msg files.

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...

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

Answer 1

Assuming you know, or can compute the full filename & path for the .msg :

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

Set MyMail = MyOutlook.CreateItemFromTemplate(fName)`

Answer 2

' 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

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

Answer 3

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):

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)

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

HTH!

Z