Export emails from Outlook Inbox folder to Excel

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
daintysallyAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

daintysallyAuthor Commented:
Can anyone help me with this?
0
dlmilleCommented:
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
daintysallyAuthor Commented:
Hi Dave,

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

438; Description

Can you tell me why?
0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

daintysallyAuthor Commented:
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
daintysallyAuthor Commented:
Should 'Set' be used here?

intRowCounter = wks.Cells(wks.Rows.Count, 1).End(xlUp).Row
0
dlmilleCommented:
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
daintysallyAuthor Commented:
Yes, I have tried the code, and I still get the error.
0
dlmilleCommented:
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
daintysallyAuthor Commented:
Ok, I commented out the on Error goto statement and the error is showing up here:

rng.Value = msg.Sender
0
dlmilleCommented:
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
dlmilleCommented:
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

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
dlmilleCommented:
Code reposted to ensure Outlook 2003 compatibility using .SenderName.

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

;)

Cheers,

Dave
0
daintysallyAuthor Commented:
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
daintysallyAuthor Commented:
msg.SenderName is not working
0
dlmilleCommented:
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
daintysallyAuthor Commented:
Sorry for the haste, it works perfectly!!!  Thank you soooo much Dave!!!
0
daintysallyAuthor Commented:
WONDERFUL!!! Dave is awesome!!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VB Script

From novice to tech pro — start learning today.