Macro - Extract Email data into Excel

Thanks to "David Lee" : http://en.gravatar.com/technotion.

Copied & Customized from:
https://techniclee.wordpress.com/2011/10/29/exporting-outlook-messages-to-excel/

Customized Ajay - Version :

Const MACRO_NAME = "Export Messages to Excel (Rev 5)"
Const EXPORT_FOLDER = "C:\Outlook\Macro_Email_Export\EXPORT_FOLDER\"
    Dim excApp As Object, _
        excWkb As Object, _
        excWks As Object, _
        intVersion As Integer, _
        strFilename As String, _
        intMessages As Integer, _
        strAtt As String

Sub ExportMessagesToExcel()
  On Error Resume Next
    'strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", MACRO_NAME)
    strFilename = "C:\Outlook\Macro_Email_Export\Export_" & Format$(Now, "yyyymmdd-hhnn")
    If strFilename <> "" Then
        intMessages = 0
        intVersion = GetOutlookVersion()
        Set excApp = CreateObject("Excel.Application")
        Set excWkb = excApp.Workbooks.Add()
        Set excWks = excWkb.ActiveSheet
        'Write Excel Column Headers
        With excWks
            .Cells(1, 1) = "Folder"
            .Cells(1, 2) = "Subject"
            .Cells(1, 3) = "Received"
            .Cells(1, 4) = "Sender"
            .Cells(1, 5) = "To"
            .Cells(1, 6) = "Attachments"
            .Cells(1, 7) = "Body"
        End With
        ProcessFolder Application.ActiveExplorer.CurrentFolder
        excApp.DisplayAlerts = False 'RESETS DISPLAY ALERTS
        excWkb.SaveAs strFilename
        excWkb.Close
        excApp.DisplayAlerts = True 'RESETS DISPLAY ALERTS
    End If
    Set excWks = Nothing
    Set excWkb = Nothing
    Set excApp = Nothing
    'MsgBox "Process complete.  A total of " & intMessages & " messages were exported.", vbInformation + vbOKOnly, MACRO_NAME
End Sub
 Sub ProcessFolder(olkFld As Outlook.MAPIFolder)
    Dim olkMsg As Object, olkSub As Outlook.MAPIFolder, intRow As Integer
    Dim olkAtt As Outlook.Attachment
    intRow = excWks.UsedRange.Rows.Count
    intRow = intRow + 1
    'Write messages to spreadsheet
    For Each olkMsg In olkFld.Items
            If olkMsg.Class = olMail Then
                'Add a row for each field in the message you want to export
                excWks.Cells(intRow, 1) = olkFld.Name
                excWks.Cells(intRow, 2) = olkMsg.Subject
                excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
                excWks.Cells(intRow, 4) = GetSMTPAddress(olkMsg, intVersion)
                excWks.Cells(intRow, 5) = olkMsg.To
                strAtt = ""
                For Each olkAtt In olkMsg.Attachments
                    If Not IsHiddenAttachment(olkAtt) Then
                        strAtt = strAtt & olkAtt.FileName & ", "
                        olkAtt.SaveAsFile EXPORT_FOLDER & Format$(olkMsg.ReceivedTime, "yyyymmdd-hhnn") & olkAtt.FileName
                    End If
                Next
                If strAtt <> "" Then
                    strAtt = Left(strAtt, Len(strAtt) - 2)
                End If
                excWks.Cells(intRow, 6) = strAtt
                excWks.Cells(intRow, 7) = olkMsg.Body
                intRow = intRow + 1
                intMessages = intMessages + 1
            End If
    Next
    Set olkMsg = Nothing
    For Each olkSub In olkFld.Folders
        ProcessFolder olkSub
    Next
    Set olkssub = Nothing
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
    Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
    On Error Resume Next
    Select Case intOutlookVersion
        Case Is < 14
            If Item.SenderEmailType = "EX" Then
                GetSMTPAddress = SMTP2007(Item)
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
        Case Else
            Set olkSnd = Item.Sender
            If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
                Set olkEnt = olkSnd.GetExchangeUser
                GetSMTPAddress = olkEnt.PrimarySmtpAddress
            Else
                GetSMTPAddress = Item.SenderEmailAddress
            End If
    End Select
    On Error GoTo 0
    Set olkPrp = Nothing
    Set olkSnd = Nothing
    Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
    Dim arrVer As Variant
    arrVer = Split(Outlook.Version, ".")
    GetOutlookVersion = arrVer(0)
   
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
    Dim olkPA As Outlook.PropertyAccessor
    On Error Resume Next
    Set olkPA = olkMsg.PropertyAccessor
    SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
    On Error GoTo 0
    Set olkPA = Nothing
End Function

Function IsHiddenAttachment(olkAtt As Outlook.Attachment) As Boolean
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim olkPA As Outlook.PropertyAccessor, varTemp As Variant
    On Error Resume Next
    Set olkPA = olkAtt.PropertyAccessor
    varTemp = olkPA.GetProperty(PR_ATTACH_CONTENT_ID)
    IsHiddenAttachment = (varTemp <> "")
    On Error GoTo 0
    Set olkPA = Nothing
End Function