Compare Emails

[parth007]

If we have Inbox email data in Excel sheet1 & Sentitem data in sheet2,
How will be be able to track the rows which are in inbox sheet & not yet replied in sentitems?
Any email tracker available for this?

VBA code

[gmayor]

This is nothing to do with Outlook. It's an Excel issue. Use the forum search function for 'Compare Worksheets', where you will find several examples to set you on your way.

[parth007]

Thanks Graham... I will surely do..
But there must be a VBA code which is accordance to Outlook only for letting us know which inbox mails are not yet replied..

[gmayor]

Indeed, but that is not what you asked for. If you want to check which messages have not been replied to then the following should establish that.



Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1
Set iFolder = Session.GetDefaultFolder(olFolderInbox).folders(i)
For Each olItem In iFolder.Items
If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
'no reply sent and message not forwarded so
'Do something with olitem here
End If
Next olItem
For j = iFolder.folders.Count To 1 Step -1
Set subFolder = iFolder.folders(j)
For Each olItem In subFolder.Items
If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
'no reply sent and message not forwarded so
'Do something with olitem here
End If
Next olItem
Next j
Next i
CleanUp:
Set olItem = Nothing
Set olItems = Nothing
Set objItem = Nothing
lbl_Exit:
Exit Sub
End Sub

[parth007]

Hi Graham, i am just a beginner in VBA outlook..
what to write instead of

'no reply sent and message not forwarded so
'Do something with olitem here
?
What will be the VBA code just to paste data on each row instead of above comments

[parth007]

I Got code to do something with olitem but after running this macro..
it only returns one row as output..
not all unreplied data..
coz i am not aware how to make it paste rows in excel one after the other in loop...

[gmayor]

It doesn't do anything because you have not said what you wanted it to do. The macro merely provides a means to identify the messages in the inbox and its sub folders that have not been replied to or forwarded. It does not do anything with those messages.

You keep referring to 'rows' and Excel, but this forum is for Outlook and the code quoted is Outlook code. There is no automatic correlation between Outlook data and Excel.

Initially you said you have a workbook in which you recorded inbox and sent data and asked how to compare them. Then you said you wanted to establish which messages in Inbox had not been replied to. Now we are back with Excel again.

Tell us what you want to do with the information and we can probably tell you how to do it. What is the Excel workbook in which you wish to record the fact? What is the name of the sheet in which you want to record it. What data from the message do you want to record?

[parth007]

Hi Graham,

Basically i was looking for VBA code which will give me the emails which are not responded.
But i could not find the way out..
But considering it as a Excel part..
Sheet1 have Inbox data & sheet 2 have sentitem data

I somehow managed to get the below details in both sheets

SenderName
To
Subject
ReceivedTime
LastModificationTime
Categories
Unread
FlagRequest

Any full proof VBA code which will actually help me highlight those emails which are not responded on the basis of the above columns details? highlighting rows in Sheet1(Inbox data)

Whats the correct columns & logic to match up.. i am still puzzled..

[gmayor]

You are not the only one who is puzzled. :)

Do you already have the received and sent messages in the worksheet? In which case my first response is the way forward. i.e. an Excel macro or function to compare the worksheets.
If the messages are in Outlook folders and not in the worksheets, but you require them there, then you will need the following modificationtro the code. This will create a workbook with sheet 1 containing a log of the messages that haven't been replied to and sheet2 a log of those that have. You need to change the path to a location on your harddrive.




Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Dim iFolder As Folder
Dim xlApp As Object
Dim xlWB As Object
Dim xlInSheet As Object
Dim xlOutSheet As Object
Dim i As Long
Dim iNextInRow As Long, iNextOutRow As Long
Dim strWorkbookPath As String
Dim strWorkbook As String
Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"

strWorkbookPath = "C:\Path\" 'path to save workbook must exist
strWorkbook = strWorkbookPath & Format(Date, "YYYY") & "_MessageLog.xlsx"

On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'On Error GoTo 0
xlApp.Visible = True
'Open the workbook to input the data
If Not FileExists(strWorkbook) Then
Set xlWB = xlApp.Workbooks.Add
With xlWB.sheets(1)
.Range("A1") = "SENDERNAME"
.Range("B1") = "TO"
.Range("C1") = "SUBJECT"
.Range("D1") = "RECEIVEDTIME"
.Range("E1") = "LASTMODIFICATIONTIME"
.Range("F1") = "CATEGORIES"
.Range("G1") = "UNREAD"
.Range("H1") = "FLAGREQUEST"
End With
With xlWB.sheets(2)
.Range("A1") = "SENDERNAME"
.Range("B1") = "TO"
.Range("C1") = "SUBJECT"
.Range("D1") = "RECEIVEDTIME"
.Range("E1") = "LASTMODIFICATIONTIME"
.Range("F1") = "CATEGORIES"
.Range("G1") = "UNREAD"
.Range("H1") = "FLAGREQUEST"
End With
xlWB.SaveAs Filename:=strWorkbook
Else
Set xlWB = xlApp.Workbooks.Open(strWorkbook)
End If

Set xlInSheet = xlWB.sheets("Sheet1")
Set xlOutSheet = xlWB.sheets("Sheet2")


'For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1 'Include sub folders
Set iFolder = Session.GetDefaultFolder(olFolderInbox) '.folders(') 'add to include sub folders

For Each olItem In iFolder.Items
If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
With xlInSheet
iNextInRow = xlInSheet.Range("A" & xlInSheet.Rows.Count).End(-4162).Row + 1
.Range("A" & iNextInRow) = olItem.Sender
.Range("B" & iNextInRow) = olItem.To
.Range("C" & iNextInRow) = olItem.Subject
.Range("D" & iNextInRow) = olItem.ReceivedTime
.Range("E" & iNextInRow) = olItem.LastModificationTime
.Range("F" & iNextInRow) = olItem.Categories
.Range("G" & iNextInRow) = olItem.UnRead
.Range("H" & iNextInRow) = olItem.FlagRequest
End With
Else
iNextOutRow = xlOutSheet.Range("A" & xlOutSheet.Rows.Count).End(-4162).Row + 1
With xlOutSheet
.Range("A" & iNextOutRow) = olItem.Sender
.Range("B" & iNextOutRow) = olItem.To
.Range("C" & iNextOutRow) = olItem.Subject
.Range("D" & iNextOutRow) = olItem.ReceivedTime
.Range("E" & iNextOutRow) = olItem.LastModificationTime
.Range("F" & iNextOutRow) = olItem.Categories
.Range("G" & iNextOutRow) = olItem.UnRead
.Range("H" & iNextOutRow) = olItem.FlagRequest
End With
End If
Next olItem
'Next i 'include subfolders
CleanUp:
Set olItem = Nothing
Set olItems = Nothing
Set objItem = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlInSheet = Nothing
Set xlOutSheet = Nothing
lbl_Exit:
Exit Sub
End Sub

[parth007]

Hi Graham,

Thanks for it, Yes i already have the INbox & sentitems data in workbook (Sheet1 & Sheet2) i have a code which helps me to download both inbox & sentitem data within a specified date range..

While running this code in a module.. i am getting nelow error on FileExists
"Sub or Function Notdefined"

[parth007]

I COmmented the IF FileExists function.. IF else & Endif i commented it executed successfully..
But it displayed data till january..
Cant we have something which will prompt for dates??
Like the user will decide the start date & end date for email fetch?

[parth007]

Below is the code i modified for storing the file.. slight file name change & auto save..
Can we have an option that while running this macro it will ask for start date & end date first before downloading the data on to the sheets?



Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Dim iFolder As Folder
Dim xlApp As Object
Dim xlWB As Object
Dim xlInSheet As Object
Dim xlOutSheet As Object
Dim i As Long
Dim iNextInRow As Long, iNextOutRow As Long
Dim strWorkbookPath As String
Dim strWorkbook As String
Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strWorkbookPath = "C:\Testing\UnrespondedEmails_" 'path to save workbook must exist
strWorkbook = strWorkbookPath & Format(Now(), "DD-MM-YYYY hh mm ss AMPM") & "_MessageLog.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'On Error GoTo 0
xlApp.Visible = True
'Open the workbook to input the data
' If Not FileExists(strWorkbook) Then
Set xlWB = xlApp.Workbooks.Add
With xlWB.Sheets(1)
.Range("A1") = "SENDERNAME"
.Range("B1") = "TO"
.Range("C1") = "SUBJECT"
.Range("D1") = "RECEIVEDTIME"
.Range("E1") = "LASTMODIFICATIONTIME"
.Range("F1") = "CATEGORIES"
.Range("G1") = "UNREAD"
.Range("H1") = "FLAGREQUEST"
End With
With xlWB.Sheets(2)
.Range("A1") = "SENDERNAME"
.Range("B1") = "TO"
.Range("C1") = "SUBJECT"
.Range("D1") = "RECEIVEDTIME"
.Range("E1") = "LASTMODIFICATIONTIME"
.Range("F1") = "CATEGORIES"
.Range("G1") = "UNREAD"
.Range("H1") = "FLAGREQUEST"
End With
xlWB.SaveAs Filename:=strWorkbook
'Else
Set xlWB = xlApp.Workbooks.Open(strWorkbook)
'End If
Set xlInSheet = xlWB.Sheets("Sheet1")
Set xlOutSheet = xlWB.Sheets("Sheet2")

'For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1 'Include sub folders
Set iFolder = Session.GetDefaultFolder(olFolderInbox) '.folders(') 'add to include sub folders

For Each olItem In iFolder.Items
If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
With xlInSheet
iNextInRow = xlInSheet.Range("A" & xlInSheet.Rows.Count).End(-4162).Row + 1
.Range("A" & iNextInRow) = olItem.Sender
.Range("B" & iNextInRow) = olItem.To
.Range("C" & iNextInRow) = olItem.Subject
.Range("D" & iNextInRow) = olItem.ReceivedTime
.Range("E" & iNextInRow) = olItem.LastModificationTime
.Range("F" & iNextInRow) = olItem.Categories
.Range("G" & iNextInRow) = olItem.UnRead
.Range("H" & iNextInRow) = olItem.FlagRequest
End With
Else
iNextOutRow = xlOutSheet.Range("A" & xlOutSheet.Rows.Count).End(-4162).Row + 1
With xlOutSheet
.Range("A" & iNextOutRow) = olItem.Sender
.Range("B" & iNextOutRow) = olItem.To
.Range("C" & iNextOutRow) = olItem.Subject
.Range("D" & iNextOutRow) = olItem.ReceivedTime
.Range("E" & iNextOutRow) = olItem.LastModificationTime
.Range("F" & iNextOutRow) = olItem.Categories
.Range("G" & iNextOutRow) = olItem.UnRead
.Range("H" & iNextOutRow) = olItem.FlagRequest
End With
End If
Next olItem
'Next i 'include subfolders
Windows(xlWB).Activate
ActiveWorkbook.Save '
ActiveWorkbook.Close
CleanUp:
Set olItem = Nothing
Set olItems = Nothing
Set objItem = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlInSheet = Nothing
Set xlOutSheet = Nothing
lbl_Exit:
Exit Sub
End Sub

[gmayor]

The following adds the date prompts and I have added the missing function that caused the error and corrected a couple of issues with the code you added. You can't use Excel commands like ActiveWorkbook.Save in Outlook with late binding to Excel as here.



Option Explicit
Sub IsReplied()
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim objItem As Outlook.MailItem
Dim iFolder As Folder
Dim xlApp As Object
Dim xlWB As Object
Dim xlInSheet As Object
Dim xlOutSheet As Object
Dim i As Long
Dim iNextInRow As Long, iNextOutRow As Long
Dim strWorkbookPath As String
Dim strWorkbook As String
Dim StartDate As String
Dim EndDate As String

StartDate = InputBox("Enter Start Date", "Start Date", Format(Date, "dd/mm/yyyy"))
If Not IsDate(StartDate) Then
MsgBox "The date you entered is not valid"
GoTo lbl_Exit
End If
EndDate = InputBox("Enter end Date", "end Date", Format(Date, "dd/mm/yyyy"))
If Not IsDate(EndDate) Then
MsgBox "The date you entered is not valid"
GoTo lbl_Exit
End If

Const PropName As String = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
strWorkbookPath = "C:\Testing\" 'path to save workbook must exist
strWorkbook = strWorkbookPath & "UnrespondedEmails_Format(Now(), "DD-MM-YYYY hh mm ss AMPM") & "_MessageLog.xlsx"
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
'On Error GoTo 0
xlApp.Visible = True
'Open the workbook to input the data
If Not FileExists(strWorkbook) Then
Set xlWB = xlApp.Workbooks.Add
With xlWB.Sheets(1)
.Range("A1") = "SENDERNAME"
.Range("B1") = "TO"
.Range("C1") = "SUBJECT"
.Range("D1") = "RECEIVEDTIME"
.Range("E1") = "LASTMODIFICATIONTIME"
.Range("F1") = "CATEGORIES"
.Range("G1") = "UNREAD"
.Range("H1") = "FLAGREQUEST"
End With
With xlWB.Sheets(2)
.Range("A1") = "SENDERNAME"
.Range("B1") = "TO"
.Range("C1") = "SUBJECT"
.Range("D1") = "RECEIVEDTIME"
.Range("E1") = "LASTMODIFICATIONTIME"
.Range("F1") = "CATEGORIES"
.Range("G1") = "UNREAD"
.Range("H1") = "FLAGREQUEST"
End With
xlWB.SaveAs Filename:=strWorkbook
Else
Set xlWB = xlApp.Workbooks.Open(strWorkbook)
End If
Set xlInSheet = xlWB.Sheets("Sheet1")
Set xlOutSheet = xlWB.Sheets("Sheet2")

'For i = Session.GetDefaultFolder(olFolderInbox).folders.Count To 1 Step -1 'Include sub folders
Set iFolder = Session.GetDefaultFolder(olFolderInbox) '.folders(') 'add to include sub folders

For Each olItem In iFolder.Items
If CDate(Format(olItem.ReceivedTime, "dd/mm/yyyy")) >= CDate(StartDate) And _
CDate(Format(olItem.ReceivedTime, "dd/mm/yyyy")) <= CDate(EndDate) Then
If olItem.PropertyAccessor.GetProperty(PropName) = 0 Then
With xlInSheet
iNextInRow = xlInSheet.Range("A" & xlInSheet.Rows.Count).End(-4162).Row + 1
.Range("A" & iNextInRow) = olItem.Sender
.Range("B" & iNextInRow) = olItem.To
.Range("C" & iNextInRow) = olItem.Subject
.Range("D" & iNextInRow) = olItem.ReceivedTime
.Range("E" & iNextInRow) = olItem.LastModificationTime
.Range("F" & iNextInRow) = olItem.Categories
.Range("G" & iNextInRow) = olItem.UnRead
.Range("H" & iNextInRow) = olItem.FlagRequest
End With
Else
iNextOutRow = xlOutSheet.Range("A" & xlOutSheet.Rows.Count).End(-4162).Row + 1
With xlOutSheet
.Range("A" & iNextOutRow) = olItem.Sender
.Range("B" & iNextOutRow) = olItem.To
.Range("C" & iNextOutRow) = olItem.Subject
.Range("D" & iNextOutRow) = olItem.ReceivedTime
.Range("E" & iNextOutRow) = olItem.LastModificationTime
.Range("F" & iNextOutRow) = olItem.Categories
.Range("G" & iNextOutRow) = olItem.UnRead
.Range("H" & iNextOutRow) = olItem.FlagRequest
End With
End If
End If
Next olItem
'Next i 'include subfolders
xlWB.Save '
xlWB.Close
CleanUp:
Set olItem = Nothing
Set olItems = Nothing
Set objItem = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlInSheet = Nothing
Set xlOutSheet = Nothing
lbl_Exit:
Exit Sub
End Sub

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

[parth007]

Perfectly worked in my case.. Thanks Graham :)
Appreciate your help