Export Outlook emails to Excel macro

[ttratl]

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:

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

 

[ttratl]

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...

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]

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]

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,