[RESOLVED] Export emails from Outlook to Excel, adding an additional column to existing code

[mrlister2000]

Hello everyone
I copied the following code from another forum but i need it to also extract the date/time from a 4th Column in an Outlook folder titled Modified but I am having no joy in getting it to pick the information and transfer it to an Excel document.
I tried copying what cell 1,2 (Received) lists, making this 1,4 Modified but it doesn't extract the new columns information.

I'm using Office 2010

Can anyone help me please?

Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strFilename As String
strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
If strFilename <> "" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.Cells(1, 1) = "Subject"
.Cells(1, 2) = "Received"
.Cells(1, 3) = "Sender"
End With
intRow = 2
'Write messages to spreadsheet
For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = olkMsg.Subject
excWks.Cells(intRow, 2) = olkMsg.ReceivedTime
excWks.Cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
intRow = intRow + 1
End If
Next
Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function

[SamOscarBrown]

Did you try this:

excWks.cells(intRow, 4) = Format(olkMsg.LastModificationTime, "MMM d yyyy hh:mm:ss")

[SamOscarBrown]

PS---are you using Option Explicit in your project? Taking your code and running it (after adding a reference to MS Outlook Library), I found undeclared variables.

[mrlister2000]

PS---are you using Option Explicit in your project? Taking your code and running it (after adding a reference to MS Outlook Library), I found undeclared variables.

if only i knew what you were talking about!

I have no experience of VBA or how to use it. i googled for help, found the code i listed but as for adding another column into it i haven't got a clue. Sorry for being a useless newbie!

[SamOscarBrown]

Well, never mind the Option Explicit. Anyway, you are posting on a Visual Basic 6 forum, not VBA.

As far as 'adding another column', see the code I added to yours in RED below. Should work just fine for you getting the Date Modified column from Outlook Mail:

''''MS OUTLOOK LIBRARY added as REFERNCE
Sub ExportMessagesToExcel()
Dim olkMsg As Object, _
excApp As Object, _
excWkb As Object, _
excWks As Object, _
intRow As Integer, _
intVersion As Integer, _
strFilename As String
'strFilename = InputBox("Enter a filename (including path) to save the exported messages to.", "Export Messages to Excel")
strFilename = App.Path & "MyExcelFileWithEmails.xlsx"
If strFilename <> "" Then
intVersion = GetOutlookVersion()
Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add()
Set excWks = excWkb.ActiveSheet
'Write Excel Column Headers
With excWks
.cells(1, 1) = "Subject"
.cells(1, 2) = "Received"
.cells(1, 3) = "Sender"
.cells(1, 4) = "Date Modified"
End With
intRow = 2
'Write messages to spreadsheet
For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.cells(intRow, 1) = Mid(olkMsg.Subject, 1, 3)
excWks.cells(intRow, 2) = olkMsg.ReceivedTime
excWks.cells(intRow, 3) = GetSMTPAddress(olkMsg, intVersion)
excWks.cells(intRow, 4) = Format(olkMsg.LastModificationTime, "MMM d yyyy hh:mm:ss")
intRow = intRow + 1

End If
Next

Set olkMsg = Nothing
excWkb.SaveAs strFilename
excWkb.Close
End If
Set excWks = Nothing
Set excWkb = Nothing
Set excApp = Nothing
MsgBox "Process complete. A total of " & intRow - 2 & " messages were exported.", vbInformation + vbOKOnly, "Export messages to Excel"
End Sub

Private Function GetSMTPAddress(Item As Outlook.MailItem, intOutlookVersion As Integer) As String
Dim olkSnd As Outlook.AddressEntry, olkEnt As Object
On Error Resume Next
Select Case intOutlookVersion
Case Is < 14
If Item.SenderEmailType = "EX" Then
GetSMTPAddress = SMTP2007(Item)
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
Case Else
Set olkSnd = Item.Sender
If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
Set olkEnt = olkSnd.GetExchangeUser
GetSMTPAddress = olkEnt.PrimarySmtpAddress
Else
GetSMTPAddress = Item.SenderEmailAddress
End If
End Select
On Error GoTo 0
Set olkPrp = Nothing
Set olkSnd = Nothing
Set olkEnt = Nothing
End Function

Function GetOutlookVersion() As Integer
Dim arrVer As Variant
arrVer = Split(Outlook.Version, ".")
GetOutlookVersion = arrVer(0)
End Function

Function SMTP2007(olkMsg As Outlook.MailItem) As String
Dim olkPA As Outlook.PropertyAccessor
On Error Resume Next
Set olkPA = olkMsg.PropertyAccessor
SMTP2007 = olkPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001E")
On Error GoTo 0
Set olkPA = Nothing
End Function

[mrlister2000]

SamOscarBrown, thank you very much. That is exactly what I have been looking for. I cannot thank you enough. Cheers!

[SamOscarBrown]

You're welcome....please mark this thread as RESOLVED (under Thread Tools link).

[mrlister2000]

You're welcome....please mark this thread as RESOLVED (under Thread Tools link).

Just one more question please!
I've modified your listing slightly to compensate for UK dates (my fault for not specifying where I was located) but when I run the macro the majority of the Modified dates are listed as DD/MM/YYYY yet a few of the dates are listing as MM/DD/YYYY. I can't figure out why this is happening? 53 out of 128 records have the MM and DD switched around.

I've tried altering the modified string above so it looks like the Received one but that doesn't work. Any ideas how to correct this within the macro?

[SamOscarBrown]

Post that section of your code....

[mrlister2000]

With excWks
.Cells(1, 1) = "From"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date Received"
.Cells(1, 4) = "Date Modified"
End With
intRow = 2
'Write messages to spreadsheet
For Each olkMsg In Application.ActiveExplorer.CurrentFolder.Items
'Only export messages, not receipts or appointment requests, etc.
If olkMsg.Class = olMail Then
'Add a row for each field in the message you want to export
excWks.Cells(intRow, 1) = GetSMTPAddress(olkMsg, intVersion)
excWks.Cells(intRow, 2) = olkMsg.Subject
excWks.Cells(intRow, 3) = olkMsg.ReceivedTime
excWks.Cells(intRow, 4) = Format(olkMsg.LastModificationTime, "dd/mm/yyyy hh:mm")

Extract from the Excel sheet :-
Received Date - 12/07/2013 14:52
Modified Date - 07/12/2013 16:21
However the Modified date should read 12/07/2013 16:21

Yet on another Row the details are correct :-
Received Date - 15/07/2013 09:05
Modified Date - 15/07/2013 17:09

[SamOscarBrown]

I cannot test this really well...my office SYSADMINS lock down our computers pretty much....and because I have a TON of messages, and the system has to VALIDATE certificates for each one, I am pretty much restricted from running your code in it's entirety.

But, try this....simply remove the format part , FROM

excWks.Cells(intRow, 4) = Format(olkMsg.LastModificationTime, "dd/mm/yyyy hh:mm")


To

excWks.Cells(intRow, 4) = olkMsg.LastModificationTime

Both SHOULD revert to your country setting on your computer....

[mrlister2000]

That works perfectly! Exactly what I needed it to do, brilliant! Thank you once again