Solved

Export emails from Outlook Inbox folder to Excel

Posted on 2012-03-09
17
1,040 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
Comment Utility
Can anyone help me with this?
0
 
LVL 41

Expert Comment

by:dlmille
Comment Utility
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
Comment Utility
Hi Dave,

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

438; Description

Can you tell me why?
0
 

Author Comment

by:daintysally
Comment Utility
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
Comment Utility
Should 'Set' be used here?

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

Expert Comment

by:dlmille
Comment Utility
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
Comment Utility
Yes, I have tried the code, and I still get the error.
0
 
LVL 41

Expert Comment

by:dlmille
Comment Utility
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
Free Trending Threat Insights Every Day

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 

Author Comment

by:daintysally
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
msg.SenderName is not working
0
 
LVL 41

Expert Comment

by:dlmille
Comment Utility
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
Comment Utility
Sorry for the haste, it works perfectly!!!  Thank you soooo much Dave!!!
0
 

Author Closing Comment

by:daintysally
Comment Utility
WONDERFUL!!! Dave is awesome!!
0

Featured Post

Do You Know the 4 Main Threat Actor Types?

Do you know the main threat actor types? Most attackers fall into one of four categories, each with their own favored tactics, techniques, and procedures.

Join & Write a Comment

Resolve DNS query failed errors for Exchange
Check out this infographic on what you need to make a good email signature that will work perfectly for your organization.
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

743 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

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now