Export outlook folder to excel

C

cchristy

New Member
Joined
Feb 24, 2011
Messages
13
Hi all,

I have been researching how to create a macro to send all mails in a folder to excel with certain data, e.g. sender, recieved time etc.

I have found the following macro:
Code: 
Sub ExportToExcel()
  On Error GoTo ErrHandler
  Dim appExcel As Excel.Application
  Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
    strSheet = "OutlookItems.xlsx"
    strPath = "C:\Examples\"
strSheet = strPath & strSheet
Debug.Print strSheet
  'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
  'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
  'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
appExcel.Application.Visible = True
  'Copy field items in mail folder.
 
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.To
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm
  Set appExcel = Nothing
  Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
  Exit Sub
ErrHandler:  If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub

this works quite well, but i need to export roughly 20 folders from different mailboxes(all contained in one profile) to the same excel file.

Can anyone help with this. I am using office 2010.

Edit: I do not mind hardcoding the folder names in if that would make it easier.
 
Last edited:

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
Here's a slightly modified version:
It should now ask you for the Excel sheet to post to
And still prompt you for the outlook folders until "Cancel" is selected
It will push all messages (only messages, not calendar items, journals, tasks or anything else) into the same workbook+sheet.
Also added which folder the item came from.

--HTH--

Code: 
Sub ExportToExcelV2()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim FolderSelected As Outlook.MAPIFolder
Dim varSender As String
Dim itm As Object
'    strSheet = "OutlookItems.xlsx"
'    strPath = "H:\"
'strSheet = strPath & strSheet
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = True
strSheet = appExcel.GetOpenFilename("Excel Files(*.xl*),*.xl*", 1, "Select Excel File", "Select", False)
appExcel.Workbooks.Open strSheet
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
  'Select export folder
Set nms = Application.GetNamespace("MAPI")
Do
Set FolderSelected = nms.PickFolder
  'Handle potential errors with Select Folder dialog box.
If FolderSelected Is Nothing Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
ElseIf FolderSelected.DefaultItemType <> olMailItem Then
    MsgBox "These are not Mail Items", vbOKOnly, "Error"
    Exit Sub
ElseIf FolderSelected.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
End If
  'Copy field items in mail folder.
 
intRowCounter = 1
colidx = 1
wks.Cells(intRowCounter, colidx) = "To": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "From": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Subject": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Sent": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Received": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Folder": colidx = colidx + 1
intRowCounter = wks.UsedRange.Rows.Count
For Each itm In FolderSelected.Items
intColumnCounter = 1
If TypeOf itm Is MailItem Then
Set msg = itm
intRowCounter = intRowCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.To
varSender = msg.SenderEmailAddress
'============================================================
If InStr(1, msg.SenderEmailAddress, "501288010", vbTextCompare) > 0 Then
    varSender = "Todd Curphey"
Else
    varSender = msg.SenderEmailAddress
End If
If InStr(1, msg.SenderEmailAddress, "CN=RECIPIENTS/CN=", vbTextCompare) > 0 Then
    varSender = "SSO: " & Right(msg.SenderEmailAddress, 9)
Else
    varSender = msg.SenderEmailAddress
    varSender = msg.SenderName
End If
'============================================================
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = varSender
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.ReceivedTime
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = FolderSelected.Name
End If 'TypeOf
Next itm
DoEvents
Loop
  Set appExcel = Nothing
  Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set FolderSelected = Nothing
Set itm = Nothing
  Exit Sub

ErrHandler:  If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: " & Err.Description & vbCrLf & msg.ReceivedTime & vbCrLf & msg.Subject, vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set FolderSelected = Nothing
Set itm = Nothing
End Sub
 
Upvote 0
tweedle said:
Here's a slightly modified version:
It should now ask you for the Excel sheet to post to
And still prompt you for the outlook folders until "Cancel" is selected
It will push all messages (only messages, not calendar items, journals, tasks or anything else) into the same workbook+sheet.
Also added which folder the item came from.

--HTH--

Code: 
Sub ExportToExcelV2()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim FolderSelected As Outlook.MAPIFolder
Dim varSender As String
Dim itm As Object
'    strSheet = "OutlookItems.xlsx"
'    strPath = "H:\"
'strSheet = strPath & strSheet
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = True
strSheet = appExcel.GetOpenFilename("Excel Files(*.xl*),*.xl*", 1, "Select Excel File", "Select", False)
appExcel.Workbooks.Open strSheet
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
  'Select export folder
Set nms = Application.GetNamespace("MAPI")
Do
Set FolderSelected = nms.PickFolder
  'Handle potential errors with Select Folder dialog box.
If FolderSelected Is Nothing Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
ElseIf FolderSelected.DefaultItemType <> olMailItem Then
    MsgBox "These are not Mail Items", vbOKOnly, "Error"
    Exit Sub
ElseIf FolderSelected.Items.Count = 0 Then
    MsgBox "There are no mail messages to export", vbOKOnly, "Error"
    Exit Sub
End If
  'Copy field items in mail folder.
 
intRowCounter = 1
colidx = 1
wks.Cells(intRowCounter, colidx) = "To": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "From": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Subject": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Sent": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Received": colidx = colidx + 1
wks.Cells(intRowCounter, colidx) = "Folder": colidx = colidx + 1
intRowCounter = wks.UsedRange.Rows.Count
For Each itm In FolderSelected.Items
intColumnCounter = 1
If TypeOf itm Is MailItem Then
Set msg = itm
intRowCounter = intRowCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.To
varSender = msg.SenderEmailAddress
'============================================================
If InStr(1, msg.SenderEmailAddress, "501288010", vbTextCompare) > 0 Then
    varSender = "Todd Curphey"
Else
    varSender = msg.SenderEmailAddress
End If
If InStr(1, msg.SenderEmailAddress, "CN=RECIPIENTS/CN=", vbTextCompare) > 0 Then
    varSender = "SSO: " & Right(msg.SenderEmailAddress, 9)
Else
    varSender = msg.SenderEmailAddress
    varSender = msg.SenderName
End If
'============================================================
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = varSender
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.Subject
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.SentOn
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.ReceivedTime
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = FolderSelected.Name
End If 'TypeOf
Next itm
DoEvents
Loop
  Set appExcel = Nothing
  Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set FolderSelected = Nothing
Set itm = Nothing
  Exit Sub
 
ErrHandler:  If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: " & Err.Description & vbCrLf & msg.ReceivedTime & vbCrLf & msg.Subject, vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set FolderSelected = Nothing
Set itm = Nothing
End Sub
Click to expand...

Thanks. This should work like a charm :)
 
Upvote 0
Hi,

Due to the large amount of information being transfered, I am getting an error.

Description: Out Of memory.

I feel this is due to
Code: 
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = msg.SentOn

being replaced with
Code: 
intColumnCounter = intColumnCounter + 1: Set rng = wks.Cells(intRowCounter, intColumnCounter): rng.Value = [B][U]msg.Body[/U][/B]

is there any way to either dump the memory after each loop or truncate the body that it only will give the first 50 characters?
 
Upvote 0
Left(msg.Body,50) would yield the first 50 chars.

Left(msg.Body,instr(1,msg.Body,"some search element i.e. signature element",vbTextCompare )) would return a variable length; so if you searched for the @ symbol as would be in most signatures, you could possibly pull the heart of the message without all of the reply threads below it.
-- would have to experiment with this one --
 
Upvote 0
tweedle said:
Left(msg.Body,50) would yield the first 50 chars.

Left(msg.Body,instr(1,msg.Body,"some search element i.e. signature element",vbTextCompare )) would return a variable length; so if you searched for the @ symbol as would be in most signatures, you could possibly pull the heart of the message without all of the reply threads below it.
-- would have to experiment with this one --
Click to expand...

Hi tweedle,

Yeah, using the left function came to me this morning. Thanks for the help on it. Never thought if using the instr function. i am looking for all emails that have thanks, thank you as the last message so the instr() helps alot.
 
Upvote 0
Decided to open a new thread here instead of hi-jacking this one

Moderators please feel free to delete this post as I can only edit.
 
Last edited:
Upvote 0
Tweedle,

very interesting code. i am impresed. so let me know. do you have any other more improved code for exporting outlook folder to excel?

thanks.

tweedle said:
Left(msg.Body,50) would yield the first 50 chars.

Left(msg.Body,instr(1,msg.Body,"some search element i.e. signature element",vbTextCompare )) would return a variable length; so if you searched for the @ symbol as would be in most signatures, you could possibly pull the heart of the message without all of the reply threads below it.
-- would have to experiment with this one --
Click to expand...
 
Upvote 0
Hello cchristy,

need your help..

your above code is working absoulty fine for mails.... i requeied same code which will export selected folders calander to excel....
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Need to add to my search worksheet
Replies
1
Views
112
craigwojo
C
C
  • Question Question
Need to search in all files within all folders also.
Replies
5
Views
452
Domenic
D
G
  • Solved
VBA to export .xlsb to .xlsx, values only (no formulas!)
Replies
8
Views
180
GVR16
G
L
  • Question Question
VBA - Search all folders for datal/text
Replies
4
Views
809
MikeVol
MikeVol
M
  • Question Question
Add text before pasting pic in outlook
Replies
2
Views
89
DanteAmor
DanteAmor

Forum statistics

Threads
1,224,618
Messages
6,179,919
Members
452,949
Latest member
beartooth91

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top