I managed to write VBA code that exports Outlook email details to Excel. I am stuck writing code to export the data based on date range.
Sub getMailbyDate()
Dim i As Long
Dim arrHeader As Variant
Dim olNS As Namespace
Dim olInboxFolder As MAPIFolder
Dim olItems As Items
Dim olItem As Variant
Set olNS = GetNamespace("MAPI")
Set olInboxFolder = olNS.PickFolder 'Pick folder
Set olItems = olInboxFolder.Items
Dim StartDate As Date, EndDate As Date
arrHeader = Array("Date Created", "SenderEmailAddress", "Subject", "Body")
ThisWorkbook.Worksheets("Output").Range("A1").Resize(1, UBound(arrHeader) + 1).Value = arrHeader
ActiveSheet.Range("E2", Range("E2").End(xlDown)).NumberFormat = "mm/dd/yyyy h:mm AM/PM"
i = 1
rngA = ThisWorkbook.Worksheets(1).Range("B7").Value
rngB = ThisWorkbook.Worksheets(1).Range("B8").Value
StartDate = DateValue(rngA)
EndDate = DateValue(rngB)
For Each olItem In olItems
' MailItem
If olItem.Class = olMail Then
If olItem.SentOn >= StartDate And olItem.SentOn <= EndDate Then
ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = olItems(i).SenderEmailAddress
ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
ThisWorkbook.Worksheets("Output").Cells(i + 1, "D").Value = olItems(i).Body
End If
' ReportItem
ElseIf olItem.Class = olReport Then
ThisWorkbook.Worksheets("Output").Cells(i + 1, "A").Value = olItems(i).CreationTime
ThisWorkbook.Worksheets("Output").Cells(i + 1, "B").Value = _
olItems(i).PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x0E04001E") 'PR_DISPLAY_TO
ThisWorkbook.Worksheets("Output").Cells(i + 1, "C").Value = olItems(i).Subject
End If
i = i + 1
Next olItem
ThisWorkbook.Worksheets(3).Cells.EntireColumn.AutoFit
MsgBox "Export complete.", vbInformation
Set olItems = Nothing
Set olInboxFolder = Nothing
Set olNS = Nothing
End Sub
I would like to export the date either by writing the date on the input box, or by writing a date range in Sheet 1.
After I export the emails I would like to filter the data in Column D (sheet 3) by a range of keywords in Sheet 2 Column A. It seems that the autofilter that I used filters data that equals the keywords in Sheet 2. I need to filter by "contains".
Sub filter()
Set sourceTemplate = ActiveWorkbook.ActiveSheet
LastRow = sourceTemplate.Cells(sourceTemplate.Rows.Count, "A").End(xlUp).Row
Dim vCrit As Variant
Dim wsOutput As Worksheet
Dim wsRules As Worksheet
Dim rngCrit As Range
Dim rngOutput As Range
Set wsOutput = Worksheets("Output")
Set wsRules = Worksheets("Rules")
Set rngOutput = wsOutput.Range("$A$1").CurrentRegion
Set rngCrit = wsRules.Range("A2:A" & LastRow)
' If filter matches criteria, write in column E "Out of the office"
vCrit = rngCrit.Value
rngOutput.AutoFilter _
Field:=3, _
Criteria1:=Application.Transpose(vCrit), _
Operator:=xlFilterValues
End Sub
Is this what you are trying? As I mentioned in the comment above you need to split up the IFs because .SentOn
will give an error for the report item.
'
'~~> Rest of your code
'
Dim StartDate As Date, EndDate As Date
'~~> rngA and rngB are relevant ranges
StartDate = DateValue(rngA.Value2)
EndDate = DateValue(rngB.Value2)
For Each olItem In olItems
If olItem.Class = olMail Then
If olItem.SentOn >= StartDate And olItem.SentOn <= EndDate Then
'~~> Rest of your code
i = i + 1
End If
ElseIf olItem.Class = olReport Then
'~~> Rest of your code
i = i + 1
End If
Next olItem
'
'~~> Rest of your code
'