Public Sub CopyHeadersToExcel(Optional ByVal excelFile As String = "C:\mail.xls")
Dim oApp As Outlook.Application
Dim oNS As Outlook.NameSpace
Dim oF As MAPIFolder
Dim oMI As Outlook.MailItem
Dim oItem As Object
Dim mailMonth As Integer
Dim mailYear As Integer
Dim oXLA As Excel.Application
Dim oXLW As Excel.Workbook
Dim oXLS As Excel.Worksheet
Dim rowCount As Long
If Month(Now) = 4 Then
mailMonth = 4
mailYear = Year(Now)
Else
mailMonth = Month(Now) - 1
mailYear = Year(Now)
End If
Set oApp = New Outlook.Application
Set oNS = oApp.GetNamespace("MAPI")
Set oF = oNS.GetDefaultFolder(olFolderInbox)
Set oXLA = New Excel.Application
Set oXLW = oXLA.Workbooks.Add
Set oXLS = oXLW.Worksheets.Add
oXLS.Name = "Mail for " & mailMonth & "-" & mailYear
For Each oItem In oF.Items
DoEvents
If Not oItem Is Nothing Then
If oItem.Class = olMail Then
Set oMI = oItem
If Month(oMI.SentOn) = mailMonth And Year(oMI.SentOn) = mailYear Then
rowCount = rowCount + 1
oXLS.Range("A" & rowCount).Value = oMI.SentOn
oXLS.Range("B" & rowCount).Value = oMI.SenderName
oXLS.Range("C" & rowCount).Value = oMI.Subject
oXLS.Range("D" & rowCount).Value = oMI.Body
End If
Set oMI = Nothing
End If
End If
Next oItem
oXLW.Close True, excelFile
oXLA.Quit
Set oXLS = Nothing
Set oXLW = Nothing
Set oXLA = Nothing
Set oMI = Nothing
Set oItem = Nothing
Set oF = Nothing
Set oNS = Nothing
Set oApp = Nothing
Call MsgBox("Finished exporting mail to " & excelFile, vbOKOnly + vbInformation, "Finished!")
End Sub