Solved

Export emails from Outlook Inbox folder to Excel

Posted on 2012-03-09
17
1,045 Views
Last Modified: 2012-03-11
Hi Experts,

I am trying to export emails from the Inbox in Outlook to an existing Excel worksheet.  I was able to modify the code below to export the fields that I need from the Inbox to an Excel spreadsheet, but I need to instead append the records from the Inbox to the next blank row in the existing worksheet.  The worksheet has a header row in the first row and a count column in column A.  I also need to add some code that will populate the count column when a new record is added.  The count is in increments of '1'.   Can someone tell me what I need to add to the code below to make this happen?


Sub Export2Excel()
  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 = "Sample.xlsx"
        strPath = "C:\Desktop\"

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

appExcel.Application.Visible = True
   
   
'Copy field items in mail folder.
For Each itm In fld.Items

intColumnCounter = 2

Set msg = itm
intRowCounter = intRowCounter + 2
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.From
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


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
0
Comment
Question by:daintysally
  • 10
  • 7
17 Comments
 

Author Comment

by:daintysally
ID: 37703483
Can anyone help me with this?
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37704320
Yes.

Before you get into your loop processing the folder items, you need to determine the next row from which you'll be writing with a statement like:

To append and initialize record counter, and keep it counting in theloop:
 'get inital row for output
    intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    
    'initialize record count

    If intRecCounter = 2 Then
       intRecCounter = 0
    Else
       intRecCounter = wks.Cells(intRowCounter, 1).Value
    End If
      
    'Copy field items in mail folder.
    For Each itm In fld.Items

        intColumnCounter = 2

        Set msg = itm
        
        intRowCounter = intRowCounter + 2
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Sender 'not from
        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
        
        'increment Record counter
        intRecCounter = intRecCounter + 1 'increment the prior count
        'output the record count
        wks.Cells(intRowCounter, 1).Value = intRecCounter

    Next itm

Open in new window

That's your initial record counter.  It needs to be initialized to 0, then incremented in your loop on each item loop, then reported out after each record is processed.

I tested your code and fixed it a bit, including a bug: you were using mailItem.From and from is not a property of the mailitem.  You want to use Sender.

E.g., msg.Sender

Also don't forget to write a few more lines of code to close out the Excel spreadsheet, or you'll lose all that good logging!  I added code at the end for that, too ;)

Finally, I played a bit with your error Handling.  You can go to a gracefulExit if successful, then after the ErrorHandling code, it can fall to gracefulExit as well.  In the gracefulExit section, you can test to see if the wkb is open, if the process was successful and save that file, closing out, then setting your objects to nothing.

Here's your code:
Option Explicit

Sub Export2Excel()
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
Dim intRecCounter As Long
Dim bSuccess As Boolean

On Error GoTo ErrHandler
    strSheet = "Sample.xlsx"
    strPath = "C:\Desktop\"

    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

    appExcel.Application.Visible = True


    'get inital row for output
    intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    
    'initialize record count

    If intRecCounter = 2 Then
       intRecCounter = 0
    Else
       intRecCounter = wks.Cells(intRowCounter, 1).Value
    End If
      
    'Copy field items in mail folder.
    For Each itm In fld.Items

        intColumnCounter = 2

        Set msg = itm
        
        intRowCounter = intRowCounter + 2
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        rng.Value = msg.Sender 'not from
        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
        
        'increment Record counter
        intRecCounter = intRecCounter + 1 'increment the prior count
        'output the record count
        wks.Cells(intRowCounter, 1).Value = intRecCounter

    Next itm
    
    bSuccess = True 'save the Excel file only if successful
    GoTo gracefulExit

ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, _
               "Error"
    Else
        MsgBox Err.Number & "; Description: ", vbOKOnly, _
               "Error"
    End If
    
gracefulExit:

    If Not wkb Is Nothing Then
        If bSuccess Then
            wkb.Close savechanges:=True
        Else
            wkb.Close savechanges:=False
        End If
        
        appExcel.Quit
    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

Open in new window


Cheers,

Dave
0
 

Author Comment

by:daintysally
ID: 37705087
Hi Dave,

Thank you!!!!! :)  When I run the code, I get the following error:

438; Description

Can you tell me why?
0
Efficient way to get backups off site to Azure

This user guide provides instructions on how to deploy and configure both a StoneFly Scale Out NAS Enterprise Cloud Drive virtual machine and Veeam Cloud Connect in the Microsoft Azure Cloud.

 

Author Comment

by:daintysally
ID: 37705162
Ok, I copied and pasted your code and instead of the 438 error, I get '9; Description'.

I changed the workbook name to delete all of the spaces out of it and now the 9 error is gone.  However, I am back to the 438 error
0
 

Author Comment

by:daintysally
ID: 37705221
Should 'Set' be used here?

intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37707465
No - because we're getting data from the .Row property (not setting a range variable to a range object).

Set would be used on something like this:

dim rLastRow as Range

set rLastRow = wks.Cells(wks.Rows.Count,1).End(xlUp)   'this is setting range variable to a range object

Have you tried the code?

;)

Dave
0
 

Author Comment

by:daintysally
ID: 37707817
Yes, I have tried the code, and I still get the error.
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37707826
Sorry, I only read your very last post.

Please comment out line 19: your on Error goto statement and then run it and advise what line you're getting the error on.
0
 

Author Comment

by:daintysally
ID: 37707872
Ok, I commented out the on Error goto statement and the error is showing up here:

rng.Value = msg.Sender
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37707878
Ahhh... That helps.  It may not matter, but what version of Office/Outlook are you using?

Also, are you processing inboxes/saved emails or sent items?

Dave
0
 
LVL 41

Accepted Solution

by:
dlmille earned 500 total points
ID: 37707903
Ok - Note, this error we are discussing is NOT from my code, but from your original code snippet.

However, I believe I know why you're getting the error.  Some of the mailItem properties are not available on certain emails.  For example, if the email item being processed by this code is sent from YOUR account, then the mailItem.Sender property would NOT exist.  Also, I changed the following to use mailItem.SenderName which is compatible back to Office 2003 just in case...

Also, the mailItem.sentOn property may not be available if the message doesn't have the PR_CLIENT_SUBMIT_TIME and PR_MESSAGE_DELIVERY_TIME stored in its content.

To avoid these errors, we need to add an error trap, collecting as much info about the email item as possible, but then moving on to the next record, as follows (note trap inside the loop at line 82, then closed out at 100):

Option Explicit

Sub Export2Excel()
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
Dim intRecCounter As Long
Dim bSuccess As Boolean

'On Error GoTo ErrHandler
    strSheet = "Sample.xlsx"
    'strPath = "C:\Desktop\"
    strPath = "C:\users\daddy\Documents\aE-E\"

    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

    appExcel.Application.Visible = True


    'get inital row for output
    intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
    
    'initialize record count

    If intRecCounter = 2 Then
       intRecCounter = 0
    Else
       intRecCounter = wks.Cells(intRowCounter, 1).Value
    End If
      
    'Copy field items in mail folder.
    For Each itm In fld.Items
        On Error Resume Next
        
        intColumnCounter = 2

        Set msg = itm

        intRowCounter = intRowCounter + 2
        Set rng = wks.Cells(intRowCounter, intColumnCounter)
        
        rng.Value = msg.SenderName 'not from

        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
        On Error GoTo 0
        
        'increment Record counter
        intRecCounter = intRecCounter + 1 'increment the prior count
        'output the record count
        wks.Cells(intRowCounter, 1).Value = intRecCounter

    Next itm
    
    bSuccess = True 'save the Excel file only if successful
    GoTo gracefulExit

ErrHandler:
    If Err.Number = 1004 Then
        MsgBox strSheet & " doesn't exist", vbOKOnly, _
               "Error"
    Else
        MsgBox Err.Number & "; Description: " & Err.Description, vbOKOnly, _
               "Error"
    End If
    
gracefulExit:

    If Not wkb Is Nothing Then
        If bSuccess Then
            wkb.Close savechanges:=True
        Else
            wkb.Close savechanges:=False
        End If
        
        appExcel.Quit
    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

Open in new window


Please advise if this clears up the issues you were having.

Cheers,

Dave
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37707937
Code reposted to ensure Outlook 2003 compatibility using .SenderName.

but be sure to change the strPath back to "C:\Desktop\"

;)

Cheers,

Dave
0
 

Author Comment

by:daintysally
ID: 37707971
Ok, I am using outlook 2007 and I am pulling emails from another inbox that I have access to in the archived folder.  I am trying your changes now
0
 

Author Comment

by:daintysally
ID: 37708001
msg.SenderName is not working
0
 
LVL 41

Expert Comment

by:dlmille
ID: 37708003
What do you mean its not working?  can you provide more information?

PS - if you're using Outlook 2007, you can use .Sender

However, I really need to understand what you mean by not working.

Dave
0
 

Author Comment

by:daintysally
ID: 37708070
Sorry for the haste, it works perfectly!!!  Thank you soooo much Dave!!!
0
 

Author Closing Comment

by:daintysally
ID: 37708072
WONDERFUL!!! Dave is awesome!!
0

Featured Post

VMware Disaster Recovery and Data Protection

In this expert guide, you’ll learn about the components of a Modern Data Center. You will use cases for the value-added capabilities of Veeam®, including combining backup and replication for VMware disaster recovery and using replication for data center migration.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This process describes the steps required to Import and Export data from and to .pst files using Exchange 2010. We can use these steps to export data from a user to a .pst file, import data back to the same or a different user, or even import data t…
Finding original email is quite difficult due to their duplicates. From this article, you will come to know why multiple duplicates of same emails appear and how to delete duplicate emails from Outlook securely and instantly while vital emails remai…
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

773 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question