Import body of all .msg files located in local drive, to and Excel sheet (NOT OUTLOOK)

Question

I'm trying to import multiple .msg files into an Excel Sheet (msg body per row)but so far the only reference found was this here, so my code so far let you:

Select the folder path (where the .msg are located)
Loop through all the .msg files

But I'm unable to figure out how to achieve my objective. Thanks in advance for the response.

Code:

    Sub importMsg()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    Dim i As Long
    Dim inPath As String
    Dim thisFile As String
    Dim msg As MailItem
    Dim OlApp As Object
    Dim ws As Worksheet

    Set ws = ThisWorkbook.Worksheets("Main")
    Set OlApp = CreateObject("Outlook.Application")

    With Application.FileDialog(msoFileDialogFolderPicker)
       .AllowMultiSelect = False
            If .Show = False Then
                Exit Sub
            End If
        On Error Resume Next
        inPath = .SelectedItems(1) & "\"
    End With

    i = 1
    thisFile = Dir(inPath & "*.msg")
    Do While thisFile <> ""
        i = i + 1
        Dim MyItem As Outlook.MailItem
        Set MyItem = Application.CreateItemFromTemplate(thisFile)
        'Set MyItem = Application.OpenSharedItem(thisFile)
        ws.Cells(i, 1).Value = MyItem.Body
        'MyItem.Body
        'MyItem.Subject
        'MyItem.Display

        thisFile = Dir
    Loop

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

There should be an On Error Goto 0 as soon as On Error Resume Next has served its purpose. For debugging, so you can see errors, you could remove it and not make the error you are purposely bypassing with On Error Resume Next. — niton, Feb 09 '16 at 11:15

score 1 · Accepted Answer · answered Feb 09 '16 at 16:19

I found the error in the Do While Loop the variable thisFile wasn't maintaining the full path reference so I added the concatenation again and worked, code below:

    Sub importMsg()
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    Dim i As Long
    Dim inPath As String
    Dim thisFile As String
    Dim Msg As MailItem
    Dim ws As Worksheet
    Dim myOlApp As Outlook.Application
    Dim MyItem As Outlook.MailItem

    Set myOlApp = CreateObject("Outlook.Application")
    Set ws = ThisWorkbook.Worksheets("Main")

    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 = 4
    Do While thisFile <> ""
        Set MyItem = myOlApp.CreateItemFromTemplate(inPath & thisFile)
        ws.Cells(i, 1) = MyItem.Body
        i = i + 1
        thisFile = Dir()
    Loop

    Set MyItem = Nothing
    Set myOlApp = Nothing

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
End Sub

Import body of all .msg files located in local drive, to and Excel sheet (NOT OUTLOOK)

1 Answers1