Can not open .msg files

Question

I have about 90 .msg, outlook files that I need to open, convert the excel attachment to .csv files and save off. Presently, the code below is to simply open the .msg outlook file, but the error appears :

How can I permit the .msg files to be opened.

Script:

Sub OpenMSGRenameDownloadAttachement()

    Dim objOL As Outlook.Application
    Dim Msg As Outlook.MailItem

    Dim MsgCount As Integer

    Set objOL = CreateObject("Outlook.Application")

    'Change the path given month, ie. do this for Jan, Feb, April
    inPath = "C:\January Messages"

    thisFile = LCase(Dir(inPath & "\*.msg"))
    Do While thisFile <> ""

        Set Msg = objOL.Session.OpenSharedItem(thisFile)

        Msg.Display

        MsgBox Msg.Subject
        thisFile = Dir
    Loop

    Set objOL = Nothing
    Set Msg = Nothing

End Sub

Answer 1

Try this:

Sub OpenMSGRenameDownloadAttachement()
Dim Msg As Outlook.MailItem
Dim objAtt As Outlook.Attachment
Set objOL = CreateObject("Outlook.Application")
Set objNs = objOL.GetNamespace("MAPI")
'objNs.Logon

inPath = "C:\January Messages\"
outPath = "C:\January Messages\attachments\" 'create this folder for attachments or use your own
thisFile = Dir(inPath & "*.msg")

Do While Len(thisFile) > 0
    Set Msg = objNs.OpenSharedItem(inPath & thisFile)
    'MsgBox inPath & thisFile
    'MsgBox Msg.Subject
    'MsgBox Msg.SenderEmailAddress
    'MsgBox Msg.Recipients.Item(1).Address
    For Each objAtt In Msg.Attachments
        If Right(objAtt, 4) = "xlsx" Or Right(objAtt, 3) = "xls" Then
            objAtt.SaveAsFile outPath & Split(objAtt.DisplayName, ".")(0) & ".csv"
        End If
    Next
    thisFile = Dir
Loop

Set objOL = Nothing
Set objNs = Nothing
End Sub