Import .msg file body to Excel

[D3allamerican07]

I am working on a process to import a folder of .msg files into excel. Each file contains a single serial number (only thing in the body) that needs to be placed on a new row. The macro below seems to work for all parts of the message except for .Body.

Goal: Loop through folder, copy body of message, paste on new row in sheet named ("Acks").

If there is a better method, please let me know! Thank you in advance!

Sub Test()

    Dim i As Long
    Dim inPath As String
    Dim thisFile As String
    Dim ws As Worksheet
    Dim olApp As Outlook.Application
    Dim MSG As Outlook.MailItem

    Set olApp = CreateObject("Outlook.Application")
    Set ws = Sheets("Acks")

    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
            If .Show = False Then
                Exit Sub
            End If
        On Error Resume Next
        inPath = .SelectedItems(1) & "\"
    End With
    thisFile = Dir(inPath & "*.msg")
    i = 2
    Do While thisFile <> ""
        Set MSG = olApp.CreateItemFromTemplate(inPath & thisFile)
        ws.Range("A" & i) = MSG.Body
        i = i + 1
        thisFile = Dir()
    Loop

    Set myItem = Nothing
    Set myOlApp = Nothing
    
 End Sub

 

[Worf]

This works for me; note that I removed the “on error” statement to allow for possible error messages:

Sub Test()
Dim i&, inPath As String, thisFile$, ws As Worksheet
Dim olApp As Outlook.Application, MSG As MailItem
Set olApp = CreateObject("Outlook.Application")
Set ws = Sheets("Acks")
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 2
Do While thisFile <> ""
    Set MSG = olApp.CreateItemFromTemplate(inPath & thisFile)
    ws.Range("A" & i) = MSG.Body
    i = i + 1
    thisFile = Dir()
Loop
Set MSG = Nothing
Set olApp = Nothing
End Sub

 

[D3allamerican07]

Worf,

Thanks for the reply. Any idea why I keep getting an "Run-time error 287: Application-defined or object-defined error" at the line

ws.Range("A" & i) = MSG.Body

 

[Worf]

See if the displayed information helps you pinpoint the issue. Does the error happen on the first message?

Sub Test()
Dim i&, inPath As String, thisFile$, ws As Worksheet
Dim olApp As Outlook.Application, MSG As MailItem
Set olApp = CreateObject("Outlook.Application")
Set ws = Sheets("Acks")
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    If .Show = False Then Exit Sub
    inPath = .SelectedItems(1) & "\"
End With
thisFile = Dir(inPath & "*.msg")
i = 2
On Error Resume Next
Do While thisFile <> ""
    Set MSG = olApp.CreateItemFromTemplate(inPath & thisFile)
    MsgBox "This file: " & thisFile & vbLf & "inPath= " & inPath & vbLf & "Subject= " & _
    MSG.Subject & vbLf & "Body= " & MSG.Body, 64, "i=" & i
    MsgBox "HTML Body= " & MSG.HTMLBody
    ws.Range("A" & i) = MSG.Body
    If Err.Number <> 0 Then
        MsgBox Err.Description, 64, Err.Number
        Exit Sub
    End If
    i = i + 1
    thisFile = Dir()
Loop
Set MSG = Nothing
Set olApp = Nothing
End Sub

 

[D3allamerican07]

Worf,

I'm sorry for the late response. Unfortunately I am still getting an application-defined error on line:

    MsgBox "This file: " & thisFile & vbLf & "inPath= " & inPath & vbLf & "Subject= " & _
    MSG.Subject & vbLf & "Body= " & MSG.Body, 64, "i=" & i

I have since decided to manually save the email as a .txt file to avoid this approach. Thank you for the help however. It is appreciated!