How to link to subfolder with current VBA Macro

[NikkiC78]

Hi,

I have the current code that works to pull directly from a shared folder's inbox. I need it to pull from the SubFolder

"Shared Email box"
> Inbox
>>"SubFolder".

Can you please tell me how i can modify the below?


Sub GetEmails()

'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Variant
Dim i As Integer
Dim Folder As Outlook.MAPIFolder
Dim sFolders As Outlook.MAPIFolder
Dim iRow As Integer, oRow As Integer
Dim strMailboxName As String
Dim Pst_Folder_Name As String
strMailboxName = "Shared Email Box"


'Mailbox or PST Main Folder Name (As how it is displayed in your Outlook Session)
strMailboxName = "Shared Email Box"

'Mailbox Folder or PST Folder Name (As how it is displayed in your Outlook Session)
Pst_Folder_Name = "Inbox" '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(strMailboxName).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(1).Activate
Folder.Items.Sort "Received"

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


'Export eMail Data from PST Folder to Excel with date and time
oRow = 1
For iRow = 1 To Folder.Items.Count
'If condition to import mails received in last 18 days
'To import all emails, comment or remove this IF condition
If VBA.DateValue(VBA.Now) - VBA.DateValue(Folder.Items.Item(iRow).ReceivedTime) <= 60 Then
oRow = oRow + 1
ThisWorkbook.Sheets(1).Cells(oRow, 1).Select
ThisWorkbook.Sheets(1).Cells(oRow, 1) = Folder.Items.Item(iRow).SenderName
ThisWorkbook.Sheets(1).Cells(oRow, 2) = Folder.Items.Item(iRow).Subject
ThisWorkbook.Sheets(1).Cells(oRow, 3) = Folder.Items.Item(iRow).ReceivedTime
ThisWorkbook.Sheets(1).Cells(oRow, 4) = Folder.Items.Item(iRow).Body


End If
Next iRow
MsgBox "Outlook Mails Extracted to Excel"
Set Folder = Nothing
Set sFolders = Nothing

End_Lbl1:
End Sub