Macro for Email Activity

[DJWH]

I sit possible to run a macro that will record email activity from an Outlook inbox and store it in a Excel file. For example, the date received and the subject line for every email that comes into an inbox would be logged.

Many thanks in advance

 

[shyrath]

The long ID is the StringID, the unique Identifier for the mail (which it keeps untill you move it to another folder)

I think the sender was SenderAddress or FromAddress, not sure, can´t test here

so would be

SendID = Olf.Items(r).FromAddress

Worksheets("Sheet1").Cells(LR, 4).Value = SendID

 

[DJWH]

The long ID is the StringID, the unique Identifier for the mail (which it keeps untill you move it to another folder)

I think the sender was SenderAddress or FromAddress, not sure, can´t test here

so would be

SendID = Olf.Items(r).FromAddress

Worksheets("Sheet1").Cells(LR, 4).Value = SendID

Neither SenderAddress nor FromAdress work. I have also tried From and Sender. Any other ideas?

 

[shyrath]

it´s SenderEmailAddress ( sorry! )

Can also add SenderName which is the name displayed.

 

[DJWH]

Thanks again- both work brilliantly!

Only problem is I want to use this on another inbox that is not my default inbox. How can I do this? Is there a way I can select a list of emails in Outlook and then run this macro on the active selection?

Thanks again

 

[shyrath]

That´s tricky

Try this

Set Olf = GetObject("Outlook.Application").GetNamespace("MAPI").Folders(1)
msgbox Olf

Unless it fails offcourse. Then we´d have to check

If Olf comes back as personal folders. Then it would be next check

Set Olf = GetObject("Outlook.Application").GetNamespace("MAPI").Folders(1).Folders("inbox")
msgbox Olf

If that comes back with inbox. then you know the location of inbox. If your folder is a subfolder of inbox it would become

Set Olf = GetObject("Outlook.Application").GetNamespace("MAPI").Folders(1).Folders("inbox").Folders("Yoursubfolder")
msgbox Olf

 

[DJWH]

No one of those work. I think I will just transfer the emails into my inbox and then run it as it only seems to work with my inbox. Do you know how I can stop the message

[SIZE=+0]“A program is trying to access e-,ail addresses you have stored in Outlook. Do you want to allow this?”"
[/SIZE]

popping up each time (and having to click ok each time)?

Thanks

 

[shyrath]

try a program called Click yes, it´s freeware

http://www.snapfiles.com/get/clickyes.html

 

[jarmov]

Hi, is there possibility to write similar macro to Excel 2010 / Outlook 2010 without Access 2010?

 

[Mr. Wizard]

I took the liberty of improving the code to get more fields and also check whether it was reading an e-mail since the code was choking on meeting notices and delivery error messages. Here is my revised code:

Sub ReadEmails()

'Stop Screen Updates
Application.ScreenUpdating = False
' Then remember to run automatic calculations back on
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'set this to the folder
Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

i = OLF.Items.Count + 1
LR = Range("A65536").End(xlUp).Row
r = 1

'Add headers at the top of the columns
Worksheets("Sheet1").Cells(1, 1).Value = "TO"
Worksheets("Sheet1").Cells(1, 2).Value = "FROM"
Worksheets("Sheet1").Cells(1, 3).Value = "DATE RECEIVED"
Worksheets("Sheet1").Cells(1, 4).Value = "SUBJECT"
Worksheets("Sheet1").Cells(1, 5).Value = "CATEGORY"
Worksheets("Sheet1").Cells(1, 6).Value = "SENDER E-MAIL ADDRESS"

Do Until r = i
If OLF.Items(r).MessageClass = "IPM.Note" Then
subs = OLF.Items(r).Subject
daterec = WorksheetFunction.Text(OLF.Items(r).ReceivedTime, "mm/dd/yy h:mm:ss AM/PM")
'strID = OLF.Items(r).EntryID
strFROM = OLF.Items(r).SenderName
strCAT = OLF.Items(r).Categories
strTO = OLF.Items(r).To
strEM = OLF.Items(r).SenderEmailAddress
End If


Worksheets("Sheet1").Cells(LR + 1, 1).Value = strTO
Worksheets("Sheet1").Cells(LR + 1, 2).Value = strFROM
Worksheets("Sheet1").Cells(LR + 1, 3).Value = daterec
Worksheets("Sheet1").Cells(LR + 1, 4).Value = subs
Worksheets("Sheet1").Cells(LR + 1, 5).Value = strCAT
Worksheets("Sheet1").Cells(LR + 1, 6).Value = strEM

r = r + 1
LR = LR + 1

Loop

'Stop Screen Updates
Application.ScreenUpdating = True
' Then remember to run automatic calculations back on
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

 

[jarmov]

Thank you very much!