Excel VBA: Loop Through a Directory of .msg files

Question

I have an excel workbook which I am using to loop through a bunch of .msg files in a folder to extract the 'sent on', 'sender' and 'subject' fields. I can extract the information but only by expressly referencing the name of the files (in this case test and test2). How do I loop through all the .msg files in the directory and extract the relevant info? This is what I have so far:

Option Explicit

Sub getMsgData()


    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    Dim mailDoc As Outlook.MailItem
    Dim i As Long
    i = 1

    Dim nam As Variant
    For Each nam In Array("test.msg", "test2.msg")
        Set mailDoc = olApp.Session.OpenSharedItem(ActiveWorkbook.Path & "\" & nam)
        Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
        Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
        Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
        mailDoc.Close False
        i = i + 1
    Next nam

    olApp.Quit

    Set mailDoc = Nothing
    Set olApp = Nothing

End Sub

Answer 1

This will loop through every file in a directory that is a .msg file Haven't used the OpenSharedItem so you may need direct & "\" & myfile in place of just myfile. I do not recommend using ActiveWorkbook.Path, but maybe you have no other way, like asking the user to select the folder in FolderPicker?

direct = ActiveWorkbook.Path
myfile = Dir(direct, "*.msg")  'sets myfile equal to the first file name
Do While myfile <> ""        'loops until there are no more files in the directory
        Set mailDoc = olApp.Session.OpenSharedItem(myfile)
        Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
        Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
        Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
        mailDoc.Close False
        i = i + 1

     myfile = Dir            

Loop

Answer 2

You do this using the Dir function. An example of how to use it is found here. For your case this is the correct code:

Option Explicit

Sub getMsgData()


    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")

    Dim mailDoc As Outlook.MailItem
    Dim i As Long
    i = 1

    Dim nam As String
    nam = Dir(ActiveWorkbook.Path & "\*.msg")
    Do While nam <> ""
        Set mailDoc = olApp.Session.OpenSharedItem(ActiveWorkbook.Path & "\" & nam)
        Sheets("sheet1").Range("a1").Offset(i) = mailDoc.SentOn
        Sheets("sheet1").Range("a1").Offset(i, 1) = mailDoc.Sender
        Sheets("sheet1").Range("a1").Offset(i, 2) = mailDoc.Subject
        mailDoc.Close False
        i = i + 1
        nam = Dir
    Loop

    olApp.Quit

    Set mailDoc = Nothing
    Set olApp = Nothing

End Sub