I recently upgraded to Outlook 2013 and now I am receiving an error when I attempt to export outlook messages to excel using a macro. Any help would be appreciated.

Mark


run-time error.jpg


SaveAs.jpg

Sub ExportMessagesToExcel()
'Originally created by Helen Feddema 9-1-2004
'Acquired from MSDN and modifed by Thomas J. Hill with coding tips from
' www.outlookcode.com and personal knowledge to export the misc and
' Monthly Email Report workbooks.
' November 2012 - While working a project for the EDI Teams, Thomas successfully applied the use of
' an array for this process. This appears to cut the export time approximately in half.



'On Error GoTo ErrorHandler

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 i As Integer 'i is the row number in the Array
Dim j As Integer 'j is the Excel row number
Dim lngCount As Long
Dim msg As Outlook.MailItem
Dim rep As Outlook.ReportItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
'Must declare as Object because folders may contain different
'types of items
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String
Dim Proceed As String

Dim fYear, rYear, iMonth As Integer
Dim rMonth As String

Dim filename As String

Dim reportArray As Variant

Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Add
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
'appExcel.Application.Visible = True
' wks.Select
wks.name = "Email"


'Adjust i (row number) to be 1 less than the number of the first body row
i = 1
j = 1

'Create Header Row
'wks.Cells(I, 1).Resize(, 6) = Array("Subject", "Body", "FromName", "ToName", "Importance", "Sensitivity")

wks.Cells(i, 1).Resize(, 3) = Array("Subject", "Body", "Received") ', "Sensitivity")

Proceed = MsgBox("Export for Misc Test?", vbYesNo, "Misc Test?")

If Proceed = vbNo Then

''Calculate the fiscal year
If Month(Date) = 12 Then
fYear = Year(Date) + 1
Else
fYear = Year(Date)
End If

'Calculate the report calendar year and report month
If Month(Date) = 1 Then
rYear = Year(Date) - 1
iMonth = 12
Else
rYear = Year(Date)
iMonth = Month(Date) - 1
End If


If iMonth < 10 Then
rMonth = "0" & iMonth
Else
rMonth = iMonth
End If

filename = "J:\JDSN Monthly E-mail Metrics\FY" _
& fYear & "\"
Dim fso As Object
Set fso = CreateObject("Scripting.filesystemobject")
If Not fso.folderexists(filename) Then
fso.createfolder (filename)
Else
End If

filename = filename & rMonth & "-" & rYear


wkb.SaveAs filename, 51

Set nms = Application.GetNamespace("MAPI")
Set fld = GetFolder("John Deere Supplier Network\My file cabinet\JDSN Mailbox") ' Coded Public Function to acquire the sought folder
If fld Is Nothing Then GoTo ErrorHandlerExit

Else

Set nms = Application.GetNamespace("MAPI")
Set fld = GetFolder("John Deere Supplier Network\Inbox") ' Coded Public Function to acquire the sought folder
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If

appExcel.DisplayAlerts = False
appExcel.ActiveWorkbook.SaveAs "J:\JDSN Support Documents\misc", 51
appExcel.DisplayAlerts = True


End If

appExcel.ScreenUpdating = False

'Test whether selected folder contains mail messages
If fld.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain mail messages"
GoTo ErrorHandlerExit
End If

lngCount = fld.Items.Count

If lngCount = 0 Then
MsgBox "No messages to export"
GoTo ErrorHandlerExit
End If

ReDim reportArray(lngCount - 1, 2) As String 'set the array size and type

i = 0 'set i to the first row of the array

'Iterate through items in the folder and export a few fields
'from each item to a row in the array

'For Each itm In fld.Items
'
' If itm.Class = olMail Then
'
'
' Set msg = itm
'
' reportArray(i, 0) = msg.Subject
' reportArray(i, 1) = msg.SenderName
' reportArray(i, 2) = msg.ReceivedTime
'
' i = i + 1
'
' Else
'
' Set rep = itm
'
' reportArray(i, 0) = rep.Subject
' reportArray(i, 1) = "Undeliverable"
' reportArray(i, 2) = rep.Importance
'
' i = i + 1
'
' End If
'
'Next itm
'
''Outlook portion complete.
''now copy from the array to the workbook.
'
'For j = 2 To lngCount + 1
'
' i = j - 2
'
' wks.Cells(j, 1).Resize(, 3) = Array(reportArray(i, 0), reportArray(i, 1), reportArray(i, 2))
'
'Next j


Dim oWks As Object
Dim oRng As Range




Set oWks = wks
Set oRng = oWks.Range("A2")


Dim ADOConn As ADODB.Connection
Dim ADORS As ADODB.Recordset
Dim ADORS2 As ADODB.Recordset
Dim strConn As String

Set ADOConn = New ADODB.Connection
Set ADORS = New ADODB.Recordset
Set ADORS2 = New ADODB.Recordset
With ADOConn
.Provider = "Microsoft.JET.OLEDB.4.0"
.ConnectionString = "Exchange 4.0;" _
& "MAPILEVEL=John Deere Supplier Network|\My file cabinet;" _
& "PROFILE=Outlook;" _
& "TABLETYPE=0;DATABASE=C:\WINDOWS\TEMP\;"
.Open
End With

With ADORS
.Open "Select Subject,[Sender Name],Received from [JDSN Mailbox] Where [Message Class]='IPM.Note' ", ADOConn, adOpenStatic, _
adLockReadOnly

oRng.CopyFromRecordset ADORS
End With
Set oRng = oRng.End(xlDown).Offset(1, 0)
With ADORS2
.Open "Select Subject,'Undeliverable',Importance from [JDSN Mailbox] Where [Message Class]<>'IPM.Note' ", ADOConn, adOpenStatic, _
adLockReadOnly

oRng.CopyFromRecordset ADORS2

.Close
End With


Set ADORS = Nothing
Set ADORS2 = Nothing
ADOConn.Close
Set ADOConn = Nothing
wks.Range("C:C").NumberFormat = "mm/dd/yy h:mm AM/PM"








'Excel population complete.
'Format col B, save, close, terminate Excel
wks.Range("B:B").Select
wks.Range("B:B").WrapText = False

wkb.Save
wkb.Close
appExcel.ScreenUpdating = True

appExcel.Quit

Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set rep = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing

ErrorHandlerExit:
Exit Sub

ErrorHandler:
If Err.Number = 429 Then
'Application object is not set by GetObject; use CreateObject instead
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description

Resume ErrorHandlerExit
End If

End Sub

Public Function TestFileExists(strFile As String) As Boolean
'Created by Helen Feddema 9-1-2004
'Last modified 9-1-2004
'Tests for existing of a file, using the FileSystemObject

Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File

On Error Resume Next

Set fil = fso.GetFile(strFile)
If fil Is Nothing Then
TestFileExists = False
Else
TestFileExists = True
End If

End Function