Download Outlook mail to excel - runtime error, array index out of bounds

Hi,

Any help would be greatly appreciated with the code below. I'm getting the error on line 'If Folder.Items.Item(iRow).Subject = SubjectLine Then'

Thanks!


Option Explicit
Sub Download_Outlook_Mail_To_Excel()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim MailBoxName As String, Pst_Folder_Name As String
Dim SubjectLine As String
Dim recip As Recipient
Dim SavePath As String
Dim RangeLower As Integer, RangeUpper As Integer, InputPath As String


'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
MailBoxName = ThisWorkbook.Sheets(1).Range("Mailbox")
SubjectLine = ThisWorkbook.Sheets(1).Range("Subject")
RangeLower = ThisWorkbook.Sheets(1).Range("Range_Lower")
RangeUpper = ThisWorkbook.Sheets(1).Range("Range_Upper")
InputPath = ThisWorkbook.Sheets(1).Range("Input_Path")

'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = ThisWorkbook.Sheets(1).Range("Folder") 'Sample "Inbox" or "Sent Items"

'To directly a Folder at a high level
'Set Folder = Outlook.Session.Folders(MailBoxName).Folders(Pst_Folder_Name)

'To access a main folder or a subfolder (level-1)
For Each Folder In Outlook.Session.Folders(MailBoxName).Folders
If VBA.UCase(Folder.Name) = VBA.UCase(Pst_Folder_Name) Then GoTo Label_Folder_Found
For Each sFolders In Folder.Folders
If VBA.UCase(sFolders.Name) = VBA.UCase(Pst_Folder_Name) Then
Set Folder = sFolders
GoTo Label_Folder_Found
End If
Next sFolders
Next Folder

Label_Folder_Found:
If Folder.Name = "" Then
MsgBox "Invalid Data in Input"
GoTo End_Lbl1:
End If

'Read Through each Mail and export the details to Excel for Email Archival
ThisWorkbook.Sheets(2).Activate
Folder.Items.Sort "Received"

'Insert Column Headers
ThisWorkbook.Sheets(2).Cells(1, 1) = "Sender"
ThisWorkbook.Sheets(2).Cells(1, 2) = "Subject"
ThisWorkbook.Sheets(2).Cells(1, 3) = "Date"
ThisWorkbook.Sheets(2).Cells(1, 4) = "EmailID"
ThisWorkbook.Sheets(2).Cells(1, 5) = "Email Address"

'Export eMail Data from PST Folder
oRow = 1
For iRow = RangeLower To RangeUpper 'Folder.Items.Count
'If condition to import mails received in last 60 days
'To import all emails, comment or remove this IF condition
'If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 5
If Folder.Items.Item(iRow).Subject = SubjectLine Then
SavePath = InputPath
For Each recip In Folder.Items.Item(iRow).Recipients
oRow = oRow + 1
ThisWorkbook.Sheets(2).Cells(oRow, 1).Select
ThisWorkbook.Sheets(2).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(2).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(2).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(2).Cells(oRow, 4) = recip.Name 'Folder.Items.Item(iRow).Recipients
ThisWorkbook.Sheets(2).Cells(oRow, 5) = recip.Address
'ThisWorkbook.Sheets(1).Cells(oRow, 6) = Folder.Items.Item(iRow).Body
Next
SavePath = SavePath & SubjectLine & iRow & ".msg"
Folder.Items.Item(iRow).SaveAs SavePath
End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing

End_Lbl1:
End Sub

Thanks Keebellah. A friend provided this code and It has been working up until now. I'm unable to figure out what has changed. Any further help would be appreciated.