Extract Email Details For All Incoming Mails Using VBA In Outlook

Hi,

I need a macro, which need to pull the below mentioned details frwom Outlook (when receving new.ema) to Excel Sheet.

Details Required:
1. From Address
2. Subject
3. Received Date and Time
4. Categories

Could pls try it and send me the macro codings!

Thanks
G.vivek.

How much are you willing to pay for that code ?


NB this forum isn't a software firm for free code !

In agreement with snb. We can help you with specific queries that you may come across in your projects, but we don't generally undertake entire projects as a whole. This is an online help community.

EDIT: Sharing the code that I had with me in the next post.

For the sake of posterity, I'm editing my comment above, and pasting the modified version of a solution that I had shared with someone a few months before.

Use this in the ThisOutlookSession module of the Outlook Application

Code:

---

Const strFilePath As String = "C:\Users\ExcelFox\Documents\Excel\OutlookMailItemsDB.xlsx"
Const strSubjectLineStartWith As String = ""
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    'Exit Sub
    Dim varArray As Variant
    Dim strSub As String
    Dim strBody As String
    Dim strArray() As String
    Dim lngLoop As Long
    Dim objItem As Object
    Dim lngMailCounter As Long
    Dim objMItem As MailItem
    strArray = Split(EntryIDCollection, ",")
    For lngMailCounter = LBound(strArray) To UBound(strArray)
        Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
        If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
            Set objMItem = objItem
            With CreateObject("Excel.Application").workbooks.Open(strFilePath)
                With .sheets(1)
                    With .cells(.rows.Count, 1).End(-4162)(2).resize(1, 5)
                        .Value = Array(objMItem.SenderEmailAddress, objMItem.Subject, objMItem.ReceivedTime, objMItem.Categories)
                    End With
                End With
                .Close 1
            End With
            Set objItem = Nothing
        End If
    Next lngMailCounter
    If Not IsEmpty(strArray) Then
        Erase strArray
    End If
   
End Sub

---

My preference:

Code:

---

Sub email_ontvangen_lezen()
  With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6)
    redim sn(.items.count,2)
 
  j=0
    for each it in .Items
      sn(j,0)=it.To
      sn(j,1)=it.subject
      sn(j,2)=it.body
      j=j+1
    next
  End With

  thisworkbook.sheets(1).cells(1).resize(ubound(sn)+1,ubound(sn,2)+1)=sn
End Sub

---

Source:
http://www.snb-vba.eu/VBA_Outlook_external_en.html#L153

To make it completely like OP has asked.

Code:

---

Sub Read_Mail()
  With CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(6)
    ReDim sn(.Items.Count, 3)
    j = 0
    For Each It In .Items
      sn(j, 0) = It.SenderEmailAddress
      sn(j, 1) = It.Subject
      sn(j, 2) = WorksheetFunction.Text(It.ReceivedTime, "mm/dd/yy h:mm:ss AM/PM")
      sn(j, 3) = It.Categories
      j = j + 1
    Next
  End With

  With Sheets(1).Cells(1)
        .Resize(, 4) = Array("FROM", "SUBJECT", "DATE RECEIVED", "CATEGORIES")
        .Offset(1).Resize(UBound(sn) + 1, UBound(sn, 2) + 1) = sn
  End With
End Sub

---

@bakerman

Since we are working in VBA I'd prefer:

Code:

---

      sn(j, 2) = format(It.ReceivedTime, "dd-mm-yyyy")

---