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
Bookmarks