Loop through all outlook emails saved on your desktop and extract the information

If you want to run a loop through all outlook mails you have stored on your local desktop. Try this code-


'Change folder path 
Public Const fldname As String = "C:\Documents and Settings\Ashish Koul\Desktop\saved_mgs\"
    Sub loop_saved_emails()
        Dim MyObj As Object, MySource As Object, file As Variant
        file = Dir(fldname)
        While (file <> "")
            If InStr(file, ".msg") > 0 Then
            Call check_details(file)
            End If
            file = Dir
        Wend
    End Sub
    
Sub check_details(flnm As Variant)
        Dim OutApp As Object
        Dim OutMail As Object
       
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.Session.OpenSharedItem(fldname & flnm)
        With OutMail
            MsgBox .Subject
            MsgBox .attachments.Count
            MsgBox .SenderName
            MsgBox .ReceivedTime
            MsgBox .body
        End With
       
       
        Set OutMail = Nothing
        Set OutApp = Nothing
    End Sub

Download Working File