Retrieve data(Time, From, subject, category) from Outlook inbox to Execl

[FrancisZheng]

Hello everybody,

I want to retrieve data from new mail received since the last execution of the macro. In this way I wouldn't need to retrieve all datas over and over again but just the new ones.

Personally I have no experience in VBA Outlook. So I was wondering if there is any good tutorial on this for Outlook beginers.

Thank you in advance.

Francis.

[mancubus]

clears the existing list and creates a new list based on last execution date.

when running the macro for the first time make sure to insert a start date after which received emails will be listed.

see attached file.



you may clear the existing data and create a new list based on last execution date:



Sub vbax_58526_retrieve_email_info_after_specific_data_time_overwrite()

Dim i As Long
Dim it As Object
Dim lastexec As Date

lastexec = Worksheets("macro_log").Range("A2").Value

On Error Resume Next
Worksheets("mail_data").UsedRange.Offset(1).Clear
i = 2
With CreateObject("Outlook.Application").GetNamespace("MAPI").Folders("MyNameAtMyDomain.com").Folders("Inbox")
For Each it In .Items
If it.ReceivedTime > lastexec Then
Select Case TypeName(it)
Case Is = "MailItem"
With Worksheets("mail_data")
.Cells(i, 1).Value = it.SenderName
.Cells(i, 2).Value = Format(it.ReceivedTime, "mm/dd/yyyy hh:mm:ss")
.Cells(i, 3).Value = it.Subject
.Cells(i, 4).Value = it.Categories
End With
i = i + 1
End Select
End If
Next it
End With

With Worksheets("macro_log")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = Now
.Cells(1).Sort Key1:=.Range("A2"), Order1:=xlDescending, Header:=xlYes
.Range("A2").NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With

End Sub


or you may add to existing data based on last execution date:


Sub vbax_58526_retrieve_email_info_after_specific_data_time_add()

Dim i As Long
Dim it As Object
Dim lastexec As Date

lastexec = Worksheets("macro_log").Range("A2").Value

On Error Resume Next

i = Worksheets("mail_data").UsedRange.Offset(1).Row

With CreateObject("Outlook.Application").GetNamespace("MAPI").Folders("MyNameAtMyDomain.com").Folders("Inbox")
For Each it In .Items
If it.ReceivedTime > lastexec Then
Select Case TypeName(it)
Case Is = "MailItem"
With Worksheets("mail_data")
.Cells(i, 1).Value = it.SenderName
.Cells(i, 2).Value = Format(it.ReceivedTime, "mm/dd/yyyy hh:mm:ss")
.Cells(i, 3).Value = it.Subject
.Cells(i, 4).Value = it.Categories
End With
i = i + 1
End Select
End If
Next it
End With

With Worksheets("macro_log")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = Now
.Cells(1).Sort Key1:=.Range("A2"), Order1:=xlDescending, Header:=xlYes
.Range("A2").NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With

End Sub

[FrancisZheng]

Hello Mancubus,

Thank you for your time and your code.

I ran it. The sheet macro_log works great. However, in the mail_data sheet, it's still empty after I executed. I adapted my email adress in the code :

...Folders("***@***.com").Folders("Inbox")...
Maybe I should also enter my mailbox name somewhere?

It's an interesting code and has potential to be working.

Regards,
Francis

[mancubus]

you are welcome

type in the name of the Outlook parent folder of Inbox as displayed in the application. it may be different than email address.

[gmayor]

I think I might be inclined to run the process from Outlook - maybe something like the following which will create a suitable workbook and write the data to it. It adds a category to the message as it is processed and only processes messages without the category. It has limitations, that may or may not be relevant, but it is faster than writing to an open workbook.


Option Explicit

Sub CopyToExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim xlSheet As Object
Dim olFolder As Outlook.Folder
Dim olitem As Object
Dim strValues As String
Const strPath As String = "C:\Path\EMail_Log.xlsx" 'the path of the workbook
'The folder must exist or you will have to add code to create it.
If Not FileExists(strPath) Then
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
'Open the workbook to input the data

Set xlWb = xlApp.workbooks.Add
Set xlSheet = xlWb.sheets("Sheet1")
xlSheet.Range("A1") = "Sender"
xlSheet.Range("B1") = "Received Time"
xlSheet.Range("C1") = "Subject"
xlWb.SaveAs strPath
xlWb.Close
xlApp.Quit
End If

Set olFolder = Session.PickFolder
For Each olitem In olFolder.Items
If TypeName(olitem) = "MailItem" Then
If Not olitem.Categories = "Logged" Then
strValues = ""
strValues = strValues & olitem.Sender.Name & "', '"
strValues = strValues & olitem.ReceivedTime & "', '"
strValues = strValues & Replace(olitem.Subject, "'", "")
WriteToWorksheet strPath, "Sheet1", strValues
olitem.Categories = "Logged"
olitem.Save
End If
End If
DoEvents
Next olitem
MsgBox "Processing Complete"
lbl_Exit:
Set xlApp = Nothing
Set xlWb = Nothing
Set xlSheet = Nothing
Set olitem = Nothing
Exit Sub
End Sub

Public Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
lbl_Exit:
Set CN = Nothing
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function

[FrancisZheng]

you are welcome

type in the name of the Outlook parent folder of Inbox as displayed in the application. it may be different than email address.

It worked perfectly except that the category column is still empty. Do you have an idea what might be the problem?

Regards,
Francis

[mancubus]

when i first run the code, it didn't return the categories as well.
i checked it and saw that there were no categorized emails in my Inbox.
after assigning color categories to some emails it worked as expected.

so make sure there are categorized emails in your Inbox after specific date.

[FrancisZheng]

when i first run the code, it didn't return the categories as well.
i checked it and saw that there were no categorized emails in my Inbox.
after assigning color categories to some emails it worked as expected.

so make sure there are categorized emails in your Inbox after specific date.

Yes, you are right. Thank you.

I found out that in the column A of macro_log, the dates are fixed on 02/02... even though their real values are different.

Do you also have this problem?

Francis

[FrancisZheng]

I think I might be inclined to run the process from Outlook - maybe something like the following which will create a suitable workbook and write the data to it. It adds a category to the message as it is processed and only processes messages without the category. It has limitations, that may or may not be relevant, but it is faster than writing to an open workbook.


Option Explicit

Sub CopyToExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim xlSheet As Object
Dim olFolder As Outlook.Folder
Dim olitem As Object
Dim strValues As String
Const strPath As String = "C:\Path\EMail_Log.xlsx" 'the path of the workbook
'The folder must exist or you will have to add code to create it.
If Not FileExists(strPath) Then
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0
'Open the workbook to input the data

Set xlWb = xlApp.workbooks.Add
Set xlSheet = xlWb.sheets("Sheet1")
xlSheet.Range("A1") = "Sender"
xlSheet.Range("B1") = "Received Time"
xlSheet.Range("C1") = "Subject"
xlWb.SaveAs strPath
xlWb.Close
xlApp.Quit
End If

Set olFolder = Session.PickFolder
For Each olitem In olFolder.Items
If TypeName(olitem) = "MailItem" Then
If Not olitem.Categories = "Logged" Then
strValues = ""
strValues = strValues & olitem.Sender.Name & "', '"
strValues = strValues & olitem.ReceivedTime & "', '"
strValues = strValues & Replace(olitem.Subject, "'", "")
WriteToWorksheet strPath, "Sheet1", strValues
olitem.Categories = "Logged"
olitem.Save
End If
End If
DoEvents
Next olitem
MsgBox "Processing Complete"
lbl_Exit:
Set xlApp = Nothing
Set xlWb = Nothing
Set xlSheet = Nothing
Set olitem = Nothing
Exit Sub
End Sub

Public Function WriteToWorksheet(strWorkbook As String, _
strRange As String, _
strValues As String)
Dim ConnectionString As String
Dim strSQL As String
Dim CN As Object
ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;"";"
strSQL = "INSERT INTO [" & strRange & "$] VALUES('" & strValues & "')"
Set CN = CreateObject("ADODB.Connection")
Call CN.Open(ConnectionString)
Call CN.Execute(strSQL, , 1 Or 128)
CN.Close
lbl_Exit:
Set CN = Nothing
Exit Function
End Function

Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function


Hello Gmayor,

Thank you for your code.

I'm still trying to understand it. I would like a program to add new data to the sheet, so I don't know if this does the same thing.

Regards,
Francis

[FrancisZheng]

Yes, you are right. Thank you.

I found out that in the column A of macro_log, the dates are fixed on 02/02... even though their real values are different.

Do you also have this problem?

Francis

Also, I would like to have the data in the descending order(newest mail on top, oldest on bottom). So I added this line between the two "With" unit :


Range("B2").CurrentRegion.Sort key1:=Range("B2"), order1:=xlDescending, Header:=xlGuess

But it didn't work so well. Could you see where's the problem?

Francis

[mancubus]

pls dont quote previous messages.

1) no. when i run the code, current date and time is placed on top of the table in macro_log

for sorting, add:


With Worksheets("mail_data")
.Cells(1).Sort Key1:=.Range("B2"), Order1:=xlDescending, Header:=xlYes
End With


before End Sub.

[FrancisZheng]

pls dont quote previous messages.

1) no. when i run the code, current date and time is placed on top of the table in macro_log

for sorting, add:


With Worksheets("mail_data")
.Cells(1).Sort Key1:=.Range("B2"), Order1:=xlDescending, Header:=xlYes
End With


before End Sub.

It works ! Thank you. I will figure out the date problem.

[FrancisZheng]

18317

[FrancisZheng]

I still can't figure it out ...

[mancubus]

the code inserts the system date & time at the bottom of the list in macro_log sheet, then sorts the values in column A in descending order.

if you run the code two or more times on the same day it's clear that it will the same dates into column A.

check if your system date is 02/02/2017.

and don't quote previous messages. they are still in the thread and we can read them without your quote.

we can examine your workbook if you upload it.

[FrancisZheng]

Problem is solved. In the code the line : ...mm/mm/yyyy should be dd/mm/yyyy.

Thank you very much mancubus !

[mancubus]

you are welcome.
mark the thread as solved from Threadtools for future references pls.

[FrancisZheng]

Problem solved ! (How do I mark the thread?)

[mancubus]

from Thread Tools dropdown which is above the first post on the right.

[FrancisZheng]

Thank you !