Private Sub Inc_Run_Time_Details_Click() Dim OutlookApp As Outlook.Application Dim OutlookNamespace As Namespace Dim Foldert As MAPIFolder Dim OutlookMail As Variant Dim filteredItemst As Outlook.Items Dim strFiltert As String Dim subj As String Dim cell As Range Dim fldrpath As String Dim currDate As String Dim incPrgTrck As String Dim emBody() As String Dim emailbody As String Dim warningmail As Variant Dim extractError As String Set OutlookApp = New Outlook.Application Set OutlookNamespace = OutlookApp.GetNamespace("MAPI") fldrpath = "\\lp99dfd\groups$\Record Extracts\New folder\New folder\" & Format(Date, "yyyymm") currDate = Format(Date, "yyyymm") incPrgTrck = fldrpath & "\INC\Progress_Tracker_" & Format(Date, "yyyymm") & "_INC.xlsx" Set Foldert = OutlookNamespace.GetDefaultFolder(olFolderInbox).Parent.Folders("AI_ZE_RECORD") strFiltert = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%AIA Record Extract%'" Set filteredItemst = Folder.Items.Restrict(strFiltert) Set wkb1 = Workbooks.Open(incPrgTrck) Set sht1 = wkb1.Sheets(currDate) filteredItemst.Sort "[ReceivedTime]", True For Each OutlookMail In filteredItemst If OutlookMail.ReceivedTime >= CDate("23-Jul-2020") And OutlookMail.ReceivedTime <= CDate("31-Jul-2020") Then subj = Split(OutlookMail.Subject)(3) For Each cell In sht1.Range("A2:A28") If InStr(cell.Value, subj) > 0 And UCase(cell.Offset(0, 3).Value) <> "SUCCESS" Then emailbody = OutlookMail.Body emBody = Split(emailbody, vbNewLine) For Each warningmail In emBody If InStr(warningmail, subj) > 0 Then extractError = Split(warningmail, "|")(4) & "|" & Split(warningmail, "|")(5) cell.Offset(0, 3).Value = extractError End If Next warningmail Exit For End If Next cell End If Next OutlookMail Set Folder = Nothing Set OutlookNamespace = Nothing Set OutlookApp = Nothing End Sub
Folders
Foldert
Folder
Set filteredItemst = Folder.Items.Restrict(strFiltert) ^
var
This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)