Extract Email Details For All Incoming Mails Using VBA In Outlook

[vivek09]

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.

[snb]

How much are you willing to pay for that code ?


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

[Excel Fox]

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.

[Excel Fox]

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


Const strFilePath As String = "C:\Users\ExcelFox\Documents\Excel\OutlookMailItems DB.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

[snb]

My preference:


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

[bakerman]

To make it completely like OP has asked.

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

[snb]

@bakerman

Since we are working in VBA I'd prefer:


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