Count number of emails I sent

[jpxvbf]

Please help. The code I got is the exact reverse of what I'm looking for. I need to see emails I sent TO. This code below shows the sender.

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 = "C:\Users\sebastjo\Documents\Message log.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

[westconn1]

you could try

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.senton
excWks.cells(intRow, 3) = olkMsg.to
excWks.cells(intRow, 4) = Format(olkMsg.LastModificationTime, "MMM d yyyy hh:mm:ss") ' probably not needed
intRow = intRow + 1

End If

[jpxvbf]

Hi, westconn1,

That worked really well. Here is the final code I will use.

If it's not too much to ask, why can't excel instead of asking me to override just save as a new sheet. (Eg. Message log, Message log(1), Message log(2)

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 = "C:\Users\sebastjo\Documents\Message log.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) = "Date Sent"
.cells(1, 3) = "Send To:"
.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, 100)
excWks.cells(intRow, 2) = olkMsg.SentOn
excWks.cells(intRow, 3) = olkMsg.To
excWks.cells(intRow, 4) = Format(olkMsg.LastModificationTime, "MMM d yyyy hh:mm:ss") ' probably not needed
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

[/QUOTE]

[westconn1]

why can't excel instead of asking me to override just save as a new sheet

because that is not what the code does

you need to open the existing workbook, rather than adding a new workbook, then add a sheet to the workbook, optionally give the sheet a name, then put the data in the new sheet, also change the excwbk.saveAs to excwbk.save, or just remove the saveAS and add true to excwbk.close true (savechanges)

Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Open(strfilename)
Set excWks = excWkb.sheets.add
excwks.name = "Messagelog(" & sheets.count & ")"
'Write Excel Column Headers
With excWks

[jpxvbf]

because that is not what the code does

you need to open the existing workbook, rather than adding a new workbook, then add a sheet to the workbook, optionally give the sheet a name, then put the data in the new sheet, also change the excwbk.saveAs to excwbk.save, or just remove the saveAS and add true to excwbk.close true (savechanges)

Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Open(strfilename)
Set excWks = excWkb.sheets.add
excwks.name = "Messagelog(" & sheets.count & ")"
'Write Excel Column Headers
With excWks

Thanks. So I replaced the code with what you written and I got a "Run-time error 424: Object Required". Can I just save as new workbook? And is this the right code?

Set excApp = CreateObject("Excel.Application")
Set excWkb = excApp.Workbooks.Add
Set excWks = excWkb.ActiveWorkbook.SaveAs
'Write Excel Column Headers
With excWks

This gave me a 'Run-time error 438'.

[westconn1]

I got a "Run-time error 424: Object Required"

on which line? file in strfilename must exist

Can I just save as new workbook? And is this the right code?

close
just change Set excWks = excWkb.ActiveWorkbook.SaveAs
to

Set excWks = excWkb.sheets(1)

you would need to supply a dynamic filename to your original saveAs statement, so that it does not overwrite
it you do want to overwrite, you could either delete the original file first or set display alerts to false

application.displayalerts = false

remember to turn alerts back on after

you can do most anything you want, just have to figure where errors occur

[jpxvbf]

on which line? file in strfilename must exist

you would need to supply a dynamic filename to your original saveAs statement, so that it does not overwrite
if you do want to overwrite, you could either delete the original file first or set display alerts to false

application.displayalerts = false

Got it. Is this the correct place to put the code? I tried it and it still asks if I want to overwrite. I don't want to overwrite, I need it to save as new workbook?

Set excApp = CreateObject("Excel.Application")
application.displayalerts = false
Set excWkb = excApp.Workbooks.Add
Set excWks = excWkb.sheets(1)
'Write Excel Column Headers
With excWks

Thanks for the help1

[westconn1]

Got it. Is this the correct place to put the code?

looks right, where do you turn displayalerts back to true?

you would need to supply a dynamic filename to your original saveAs statement,

a dynamic file name would resolve the issue, like you could use a number, or a timevalue, or something to make it unique, then it will not overwrite, what you use might depend how often you want to create a new file
you could try something like

excwbk.saveAs left(strfilename, len(strfilename) - 5) & format(now, "yyyymmddhhmmss") & ".xlsx"

you may not need to use seconds or minutes or even time at all if the file is not saved so often