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]

you can likely do that from outlook VBA aswel.

but this method works for me.

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 = CreateObject("Outlook.Application").GetNamespace("MAPI").Folders(1).Folders("inbox")

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

Do Until r = i

subs = UCase(Olf.Items(r).Subject)
strID = Olf.Items(r).EntryID



Worksheets("Sheet1").Cells(LR, 1).Value = subs
Worksheets("Sheet1").Cells(LR, 2).Value = Date
Worksheets("Sheet1").Cells(LR, 3).Value = strID

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

 

[shyrath]

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 = CreateObject("Outlook.Application").GetNamespace("MAPI").Folders(1).Folders("inbox")

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

Do Until r = i

subs = Olf.Items(r).Subject
daterec = Olf.Items(r).ReceivedTime
strID = Olf.Items(r).EntryID



Worksheets("Sheet1").Cells(LR, 1).Value = subs
Worksheets("Sheet1").Cells(LR, 2).Value = daterec
Worksheets("Sheet1").Cells(LR, 3).Value = strID

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

Slightly modified to include received date

 

[DJWH]

Thanks. I really appreciate your response. However it doesn't seem to work and I think it's to do with this line:

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

Could you help explain this for me?

Thanks again

 

[shyrath]

Your outlook folder may have a different name or location.

Folders(1) should equal personal folders and (inbox) the inbox underneath personal folders.

 

[DJWH]

Thanks. I still get an error in that line. It says:

Run-time Error '-2147221233 (8004010f)':

The operation failed. An object could not be found.

Is it to do with "GetNamespace("MAPI")"?

 

[shyrath]

What versions of outlook and excel are you running?

 

[DJWH]

Both 2003 versions.

 

[shyrath]

Set OLF = GetObject("", _
"Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

could be that you need to set a reference in the VBA project to the Microsoft Outlook 8.0 Object Library (in vba go to tools / References)

 

[DJWH]

That works! Thanks for all your help- I really appreciate it. Just a couple of points:

- How do I return who it's from?
- Also the third column seems to be some sort of long string- what is this?

Finally, how do I change it so that it's not my default mailbox but another one called say "Folder 2"?

Thanks again