Export Outlook emails to Excel macro

ttratl

Board Regular
Joined
Dec 21, 2004
Messages
168
Hi Everyone,

Just been upgraded from Win XP to Win 7, and I have another problem I can't solve. This macro exports emails from a folder in Outlook into an already opened Excel worksheet:
Code:
Sub ExportToExcel2()

  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
  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
  
  'Activate existing open Excel workbook.

 >>>>>>>>>>>>>>>>>>>>>>>>  Set appExcel = GetObject(, "Excel.Application")
    
    'appExcel.Workbooks.Open (strSheet) 'causes "doesn't exist" error
    Set wkb = appExcel.ActiveWorkbook
    Set wks = wkb.ActiveSheet
    wks.Activate
    appExcel.Application.Visible = True
    
        'try changing:
        'Range("A65536").End(xlUp).Offset(1, 0).Select
        'to:
        intRowCounter = wks.Range("A65536").End(xlUp).Row '+ 1

          
  'Copy field items in mail folder.
  For Each itm In fld.Items
    intColumnCounter = 1
    Set Msg = itm
    intRowCounter = intRowCounter + 1
    
    'From
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Msg.SenderEmailAddress
    intColumnCounter = intColumnCounter + 1
    
    'To
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Msg.To
    intColumnCounter = intColumnCounter + 1
    
    'CC
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Msg.CC
    intColumnCounter = intColumnCounter + 1
    
    'Date sent
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Msg.SentOn
    intColumnCounter = intColumnCounter + 1
    
    'Date received
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Msg.ReceivedTime
    intColumnCounter = intColumnCounter + 1
    
    'Subject
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Msg.Subject
    intColumnCounter = intColumnCounter + 1
    
    'Message
    Set rng = wks.Cells(intRowCounter, intColumnCounter)
    rng.Value = Msg.Body
        
    'Set rng = wks.Cells(intRowCounter, intColumnCounter)
    'rng.Value = msg.Body
    'intColumnCounter = intColumnCounter + 1
    
  Next itm
  
        'run a macro in Excel:
            appExcel.Run "TidyOutput_v2"
  
  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 macro errors at the 'Set appExcel = GetObject(, "Excel.Application")' line.
I've tried commenting it out in favour of the line below, but that errors too. The error dialog that appears has "-2147319779; Description" or "-91; Description", with the other line, and an OK button which stops the macro.

The only thing that is different from when it was working is the O/S - Win XP to Win 7. I've added the Excel12 Object Library in Tools-References, so I'm a bit stumped.

Any ideas welcomed..
Thanks
 

Some videos you may like

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

ttratl

Board Regular
Joined
Dec 21, 2004
Messages
168
I didn't get any response to this post, but I've managed to solve it myself. Thought I'd post my solution, in case it may help others...
Code:
Sub ExportToExcel2()

  On Error GoTo ErrHandler

'  Dim appExcel As Excel.Application 'Declare the object variable
'  Dim wkb As Excel.Workbook
'  Dim wks As Excel.Worksheet
'  Dim rng As Excel.Range
'  Dim strSheet As String               :: This is all Pre Win7 Code        ::
'  Dim strPath As String                :: the Excel Statements are now     ::
'  Dim intRowCounter As Integer         :: declared as Objects (see below) ::
'  Dim intColumnCounter As Integer
'  Dim msg As Outlook.MailItem
'  Dim nms As Outlook.NameSpace
'  Dim fld As Outlook.MAPIFolder
'  Dim itm As Object
'  Debug.Print strSheet

  Dim appExcel As Object '::changed for Win7::
  Dim wkb As Object      '::changed for Win7::
  Dim wks As Object      '::changed for Win7::
  Dim rng As Object      '::changed for Win7::
  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
  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
  
  'Activate existing open Excel workbook.
    Set appExcel = GetObject(, "Excel.Application")  ':: Declared 'Objects' must have 'Set' with them ::
    Set wkb = appExcel.ActiveWorkbook                ':: ---------------- " ------------------------- ::
    Set wks = wkb.ActiveSheet                        ':: ---------------- " ------------------------- ::
    appExcel.Visible = True  'wks.Activate              :: these 2 lines are reversed from WinXP ::
    wks.Activate             'appExcel.Visible = True   :: these 2 lines are reversed from WinXP ::
    
'find the next available row on the worksheet:
    intRowCounter = wks.Range("A65536").End(xlUp).Row '+ 1

'Copy field items in mail folder.
        For Each itm In fld.Items
          intColumnCounter = 1
          Set msg = itm
          intRowCounter = intRowCounter + 1
    
          'From
          Set rng = wks.Cells(intRowCounter, intColumnCounter)
          rng.Value = msg.SenderEmailAddress
          intColumnCounter = intColumnCounter + 1
          
          'To
          Set rng = wks.Cells(intRowCounter, intColumnCounter)
          rng.Value = msg.To
          intColumnCounter = intColumnCounter + 1
          
          'CC
          Set rng = wks.Cells(intRowCounter, intColumnCounter)
          rng.Value = msg.CC
          intColumnCounter = intColumnCounter + 1
          
          'Date sent
          Set rng = wks.Cells(intRowCounter, intColumnCounter)
          rng.Value = msg.SentOn
          intColumnCounter = intColumnCounter + 1
          
          'Date received
          Set rng = wks.Cells(intRowCounter, intColumnCounter)
          rng.Value = msg.ReceivedTime
          intColumnCounter = intColumnCounter + 1
          
          'Subject
          Set rng = wks.Cells(intRowCounter, intColumnCounter)
          rng.Value = msg.Subject
          intColumnCounter = intColumnCounter + 1
          
          'Message
          Set rng = wks.Cells(intRowCounter, intColumnCounter)
          rng.Value = msg.Body
              
          'Set rng = wks.Cells(intRowCounter, intColumnCounter)
          'rng.Value = msg.Body
          'intColumnCounter = intColumnCounter + 1
          
        Next itm
  
'run a macro in Excel:
    appExcel.Run "TidyOutput_v2"
  
'unload memory:
  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
 

ProgramUser

Board Regular
Joined
Apr 15, 2014
Messages
75
Thanks for posting this in at the forum Ttratl.... Was VERY useful for me as I was having numerous problems with 'file not found' or 'path does not exist' errors that were driving me crazy - so thanks again! :)

May I ask you some further questions based on your above code?

Thanks
ProgramUser
 

ProgramUser

Board Regular
Joined
Apr 15, 2014
Messages
75
Hey Ttratl - just one thing.... Using your code exactly as you have posted and it is working except for this..... - I am receiving the following error;

13;Description:

Not sure why, I have been through the code and have researched the error.... Any thoughts at your end? The open excel worksheet is receiving data from the above export, hence my query???

Thanks,
 

Watch MrExcel Video

Forum statistics

Threads
1,123,087
Messages
5,599,658
Members
414,325
Latest member
kfg1287

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
Top