analyze the vba codes of this excel file other functionalities is working perfectly fine except the follow up so with keeping every functionalities excep the follow up I want you to edit that part

edit it what its currently doing for follow up is making another email with the same subject on the list and using the recepient in the recepient column of the list, what I want it to do is reply to the latest response on the email conversation thread of the email in the list and not create a new one cause when I tried this code when It send an automatic follow up new email was created and no email thread of the previous emails. send me the new entire updated vba codes for all modules that will be needed, send the entire codes for each modules.   

also for escalation emails can you add MDM escalation -  at the start of the subject so for example if the subject is test and it got escalated then the escallation email should have a title of MDM escalation - test.




can you analyze all the codes for all the modules of the entire tracker look for possible errors and fix them. iF A MODULE IN THE TRACKER NEEDS TO BE UPDATED BASED ON WHAT I REQUESTED ABOVE SEND THE COMPLETE UPDATED CODE FOR THAT MODULE I WANT YOU TO SEND THE complete and ENTIRECODE AND DOT SHORTCUT IT BY SAYING PUT THE REST OF THE CODE HERE. SEND THE ENTIRE UPDATED CODES HOWEVER IF A MODULE NEEDS NO UPDATE DONT SEND THEM AGAIN( FOR EXAMPLE BASED ON MY REQUEST ABOVE ONLY UTILITYMODULE NEEDS TO BE UPDATED AND THE OTHER MODULES CAN BE KEPT THE SAME, YOU SHOULD ONLY SEND ME THE COMPLETE UPDATED CODE FOR UTILITYMODULE) HOWEVER IF BASED ON MY REQUEST ABOVE IS ALL OF THE MODULES NEEDS TO BE UPDATED PLEASE FOLLOW INSTRUCTIONS BELOW BECAUSE ALL OF THE CODES ARE TOO LONG TO SEND IN ONE GO.

send me first the sheet1, thisworkbook, datavisualiyation, helper and setupmodule then after that ask me first if you can send the rest of the codes before sending the rest of the codes for the rest of the modules that will be needed. send the entire code for each of the modules.before giving me the updated codes check first for possible errors in the new updated codes fix that so that everzthing will work smoothly when I try them dont shortcut them. 


send only the complete updated of the modules that need to be updated DONT PUT THE REST OF THE CODE SEND THE ENTIRE UPDATED CODE FOR THAT MODULE
I TOLD YOU TO SEND THE THE ENTIRECODE AND DOT SHORTCUT IT BY SAYING PUT THE REST OF THE CODE HERE. SEND THE ENTIRE UPDATED CODES FOR THAT MODULE

I TOLD YOU TO SEND THE THE complete and ENTIRECODE AND DOT SHORTCUT IT BY SAYING PUT THE REST OF THE CODE HERE. SEND THE ENTIRE UPDATED CODES FOR THE MODULES THAT NEED TO BE UPDATED ONLY


THE CODES FOR THE ENTIRE TRACKER IS BELOW:
Sheet1 - 1
Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
 On Error GoTo ErrorHandler
 Call HyperlinkClicked(Target)
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while handling hyperlink: " & Err.Description, vbExclamation
 Debug.Print "Error in Worksheet_FollowHyperlink: " & Err.Description
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 On Error GoTo ErrorHandler
 If Not Intersect(Target, Me.Columns(1)) Is Nothing Then
 If Target.Hyperlinks.Count > 0 Then
 Call HyperlinkClicked(Target.Hyperlinks(1))
 Cancel = True
 End If
 End If
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while handling double-click: " & Err.Description, vbExclamation
 Debug.Print "Error in Worksheet_BeforeDoubleClick: " & Err.Description
End Sub
ThisWorkbook - 1
Option Explicit
Private Sub Workbook_Open()
 On Error GoTo ErrorHandler
 Call InitializeFullEmailTracker
 Application.OnTime Now + TimeSerial(0, 0, 5), "CheckEmailResponses" ' Delay to allow initialization
 Call StartResponseCheckTimer ' Start the timer for periodic checking
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while opening the workbook: " & Err.Description, vbExclamation
 Debug.Print "Error in Workbook_Open: " & Err.Description
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 On Error GoTo ErrorHandler
 Call StopResponseCheckTimer
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while closing the workbook: " & Err.Description, vbExclamation
 Debug.Print "Error in Workbook_BeforeClose: " & Err.Description
End Sub
DataVisualizationModule - 1
Option Explicit
Public Sub CreateDataVisualization()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim chartSheet As Worksheet
 On Error Resume Next
 Set chartSheet = ThisWorkbook.Sheets("Charts")
 If chartSheet Is Nothing Then
 Set chartSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
 chartSheet.Name = "Charts"
 Else
 chartSheet.Cells.Clear
 End If
 On Error GoTo 0
 CreateStatusChart chartSheet, ws
 CreateResponseChart chartSheet, ws
 MsgBox "Data visualization charts have been created on the 'Charts' sheet.", vbInformation
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in CreateDataVisualization: " & Err.Description, vbExclamation
 Debug.Print "Error in CreateDataVisualization: " & Err.Description
End Sub
Private Sub CreateStatusChart(chartSheet As Worksheet, ws As Worksheet)
 On Error GoTo ErrorHandler
 Dim statusCounts As Object
 Set statusCounts = CreateObject("Scripting.Dictionary")
 Dim lastRow As Long
 lastRow = GetLastDataRow(ws)
 Dim i As Long
 For i = 5 To lastRow
 Dim status As String
 status = ws.Cells(i, 3).Value ' Status in Column C
 If statusCounts.Exists(status) Then
 statusCounts(status) = statusCounts(status) + 1
 Else
 statusCounts.Add status, 1
 End If
 Next i
 ' Prepare data for chart
 chartSheet.Cells(1, 1).Value = "Status"
 chartSheet.Cells(1, 2).Value = "Count"
 Dim index As Integer
 index = 2
 Dim key As Variant
 For Each key In statusCounts.Keys
 chartSheet.Cells(index, 1).Value = key
 chartSheet.Cells(index, 2).Value = statusCounts(key)
 index = index + 1
 Next key
 ' Create chart
 Dim cht As ChartObject
 Set cht = chartSheet.ChartObjects.Add(Left:=10, Top:=10, Width:=500, Height:=300)
 With cht.Chart
 .SetSourceData Source:=chartSheet.Range("A1:B" & index - 1)
 .ChartType = xlPie
 .HasTitle = True
 .ChartTitle.Text = "Email Status Distribution"
 .Legend.Position = xlLegendPositionRight
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in CreateStatusChart: " & Err.Description, vbExclamation
DataVisualizationModule - 2
 Debug.Print "Error in CreateStatusChart: " & Err.Description
End Sub
Private Sub CreateResponseChart(chartSheet As Worksheet, ws As Worksheet)
 On Error GoTo ErrorHandler
 Dim daysSinceResponseCounts As Object
 Set daysSinceResponseCounts = CreateObject("Scripting.Dictionary")
 Dim lastRow As Long
 lastRow = GetLastDataRow(ws)
 Dim i As Long
 For i = 5 To lastRow
 If ws.Cells(i, 8).Value <> "" Then ' Last Response Date in Column H
 Dim days As Long
 days = DateDiff("d", ws.Cells(i, 8).Value, Now)
 If daysSinceResponseCounts.Exists(days) Then
 daysSinceResponseCounts(days) = daysSinceResponseCounts(days) + 1
 Else
 daysSinceResponseCounts.Add days, 1
 End If
 End If
 Next i
 ' Prepare data for chart
 Dim chartStartRow As Integer
 chartStartRow = chartSheet.Cells(chartSheet.Rows.Count, 1).End(xlUp).row + 2
 chartSheet.Cells(chartStartRow, 1).Value = "Days Since Last Response"
 chartSheet.Cells(chartStartRow, 2).Value = "Count"
 Dim index As Integer
 index = chartStartRow + 1
 Dim key As Variant
 For Each key In daysSinceResponseCounts.Keys
 chartSheet.Cells(index, 1).Value = key
 chartSheet.Cells(index, 2).Value = daysSinceResponseCounts(key)
 index = index + 1
 Next key
 ' Create chart
 Dim cht As ChartObject
 Set cht = chartSheet.ChartObjects.Add(Left:=10, Top:=320, Width:=500, Height:=300)
 With cht.Chart
 .SetSourceData Source:=chartSheet.Range("A" & chartStartRow & ":B" & index - 1)
 .ChartType = xlColumnClustered
 .HasTitle = True
 .ChartTitle.Text = "Days Since Last Response"
 .Axes(xlCategory).HasTitle = True
 .Axes(xlCategory).AxisTitle.Text = "Days"
 .Axes(xlValue).HasTitle = True
 .Axes(xlValue).AxisTitle.Text = "Count"
 .Axes(xlCategory).TickLabelSpacing = 1
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in CreateResponseChart: " & Err.Description, vbExclamation
 Debug.Print "Error in CreateResponseChart: " & Err.Description
End Sub
HelperModule - 1
Option Explicit
Public Function GetLastDataRow(ws As Worksheet) As Long
 On Error Resume Next
 ' Find the last row with data in column A
 GetLastDataRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
 ' Ensure we don't count the header row (row 4) as data
 If GetLastDataRow < 5 Then GetLastDataRow = 4
 On Error GoTo 0
End Function
Public Function GetNextAvailableRow(ws As Worksheet) As Long
 GetNextAvailableRow = GetLastDataRow(ws) + 1
 If GetNextAvailableRow < 5 Then GetNextAvailableRow = 5
End Function
Public Function GetPreference(prefName As String) As Variant
 Dim wsPreferences As Worksheet
 Set wsPreferences = ThisWorkbook.Sheets(SHEET_NAME_PREFERENCES)
 Dim lastRow As Long, i As Long
 lastRow = wsPreferences.Cells(wsPreferences.Rows.Count, 1).End(xlUp).row
 For i = 1 To lastRow
 If wsPreferences.Cells(i, 1).Value = prefName Then
 GetPreference = wsPreferences.Cells(i, 2).Value
 Exit Function
 End If
 Next i
 ' Default values if preference not found
 Select Case prefName
 Case "Response Check Interval (Minutes)"
 GetPreference = 1
 Case "First Follow-Up Interval (Days)"
 GetPreference = 1
 Case "Escalation Interval (Days)"
 GetPreference = 10
 Case Else
 GetPreference = ""
 End Select
End Function
ImportExportModule - 1
Option Explicit
Public Sub ExportData()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim saveFileDialog As FileDialog
 Set saveFileDialog = Application.FileDialog(msoFileDialogSaveAs)
 With saveFileDialog
 .Title = "Save As CSV"
 .InitialFileName = "EmailTracker_" & Format(Now, "yyyy_mm_dd_hh_mm_ss") & ".csv"
 .Filters.Clear
 .Filters.Add "CSV Files", "*.csv", 1
 .Filters.Add "All Files", "*.*", 2
 .FilterIndex = 1
 If .Show = -1 Then
 Dim filePath As String
 filePath = .SelectedItems(1)
 ' Copy data to a new workbook
 Dim exportWb As Workbook
 Set exportWb = Workbooks.Add
 ws.Range("A4:J" & GetLastDataRow(ws)).Copy
 exportWb.Sheets(1).Range("A1").PasteSpecial xlPasteValues
 Application.CutCopyMode = False
 With exportWb
 .SaveAs Filename:=filePath, FileFormat:=xlCSV
 .Close SaveChanges:=False
 End With
 MsgBox "Data exported successfully!", vbInformation
 End If
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in ExportData: " & Err.Description, vbExclamation
 Debug.Print "Error in ExportData: " & Err.Description
End Sub
Public Sub ImportData()
 On Error GoTo ErrorHandler
 Dim openFileDialog As FileDialog
 Set openFileDialog = Application.FileDialog(msoFileDialogFilePicker)
 With openFileDialog
 .Title = "Import CSV"
 .Filters.Clear
 .Filters.Add "CSV Files", "*.csv", 1
 .Filters.Add "All Files", "*.*", 2
 .FilterIndex = 1
 If .Show = -1 Then
 Dim importFilePath As String
 importFilePath = .SelectedItems(1)
 ' Open the CSV file
 Dim importWb As Workbook
 Set importWb = Workbooks.Open(importFilePath)
 ' Copy data excluding headers
 Dim importWs As Worksheet
 Set importWs = importWb.Sheets(1)
 Dim importLastRow As Long
 importLastRow = importWs.Cells(importWs.Rows.Count, 1).End(xlUp).row
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim lastRow As Long
 lastRow = GetNextAvailableRow(ws) - 1
 ' Copy data
 importWs.Range("A2:J" & importLastRow).Copy
 ws.Cells(lastRow + 1, 1).PasteSpecial xlPasteValues
 Application.CutCopyMode = False
 importWb.Close SaveChanges:=False
ImportExportModule - 2
 MsgBox "Data imported successfully!", vbInformation
 ' Reformat the sheet
 FormatTrackerSheet ws
 End If
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in ImportData: " & Err.Description, vbExclamation
 Debug.Print "Error in ImportData: " & Err.Description
End Sub
SetupModule - 1
Option Explicit
' Constants for sheet names and button captions
Public Const SHEET_NAME_MAIN As String = "Sheet1"
Public Const SHEET_NAME_LOG As String = "ActivityLog"
Public Const SHEET_NAME_FOLLOW_UP As String = "FollowUpMessages"
Public Const SHEET_NAME_PREFERENCES As String = "Preferences"
Public Const BTN_CAPTION_ADD As String = "Add to List"
Public Const BTN_CAPTION_DELETE As String = "Delete"
Public Const BTN_CAPTION_SEND_FOLLOW_UP As String = "Send Follow-Up"
Public Const BTN_CAPTION_CHECK_RESPONSES As String = "Check Responses"
Public Const BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL As String = "Send Follow-Up To All"
Public Const BTN_CAPTION_DATA_VISUALIZATION As String = "Data Visualization"
Public Const BTN_CAPTION_IMPORT_DATA As String = "Import Data"
Public Const BTN_CAPTION_EXPORT_DATA As String = "Export Data"
Public Const BTN_CAPTION_CLOSE_TRACKER As String = "Close Tracker"
Public Const BACKUP_INTERVAL_HOURS As Integer = 1
Public Const DEFAULT_BACKUP_PATH As String = "C:\Backups\"
Public Sub InitializeFullEmailTracker()
 On Error GoTo ErrorHandler
 Dim wsMain As Worksheet, wsLog As Worksheet, wsFollowUp As Worksheet, wsPreferences As Worksheet
 Set wsMain = EnsureSheetExists(SHEET_NAME_MAIN)
 Set wsLog = EnsureSheetExists(SHEET_NAME_LOG)
 Set wsFollowUp = EnsureSheetExists(SHEET_NAME_FOLLOW_UP)
 Set wsPreferences = EnsureSheetExists(SHEET_NAME_PREFERENCES)
 SetupHeaders wsMain
 SetupInputFields wsMain
 SetupButtons wsMain
 SetupActivityLog wsLog
 SetupFollowUpMessages wsFollowUp
 SetupPreferences wsPreferences
 ' Format the tracker sheet
 FormatTrackerSheet wsMain
 ' Activate the main sheet
 wsMain.Activate
 ' MsgBox "Email Tracker Initialized. You're ready to go!", vbInformation
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred: " & Err.Description, vbExclamation
 Debug.Print "Error in InitializeFullEmailTracker: " & Err.Description
End Sub
Private Function EnsureSheetExists(sheetName As String) As Worksheet
 Dim ws As Worksheet
 On Error Resume Next
 Set ws = ThisWorkbook.Sheets(sheetName)
 On Error GoTo 0
 If ws Is Nothing Then
 Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
 ws.Name = sheetName
 End If
 Set EnsureSheetExists = ws
End Function
Private Sub SetupHeaders(ws As Worksheet)
 On Error GoTo ErrorHandler
 With ws
 ' Input labels
 .Cells(1, 1).Value = "Email Subject:"
 .Cells(1, 2).Value = "Recipients:"
 ' Data table headers starting from Row 4
 .Cells(4, 1).Value = "Email Subject"
 .Cells(4, 2).Value = "Recipients"
 .Cells(4, 3).Value = "Status"
 .Cells(4, 4).Value = "Remarks"
 .Cells(4, 5).Value = "Last Follow-Up Date"
SetupModule - 2
 .Cells(4, 6).Value = "Delete"
 .Cells(4, 7).Value = "Send Follow-Up"
 .Cells(4, 8).Value = "Last Response Date" ' Column H
 .Cells(4, 9).Value = "Follow-Up Count" ' Column I
 .Cells(4, 10).Value = "ConversationID" ' Column J (New column)
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up headers: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupHeaders: " & Err.Description
End Sub
Private Sub SetupInputFields(ws As Worksheet)
 On Error GoTo ErrorHandler
 With ws
 .Cells(2, 1).Value = ""
 .Cells(2, 2).Value = ""
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up input fields: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupInputFields: " & Err.Description
End Sub
Private Sub SetupButtons(ws As Worksheet)
 On Error GoTo ErrorHandler
 Dim shp As Shape
 Dim rng As Range
 ' ------- Left Column Buttons -------
 ' Add To List button
 If Not ButtonExists(ws, BTN_CAPTION_ADD) Then
 Set rng = ws.Range("D1:E1")
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_ADD
 .OnAction = "AddEmailToList"
 .Name = "Button_AddToList"
 .Fill.ForeColor.RGB = RGB(0, 176, 80) ' Green
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 .Placement = xlMoveAndSize
 .LockAspectRatio = msoTrue
 End With
 End If
 ' Check Responses button
 If Not ButtonExists(ws, BTN_CAPTION_CHECK_RESPONSES) Then
 Set rng = ws.Range("D2:E2")
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_CHECK_RESPONSES
 .OnAction = "CheckEmailResponses"
 .Name = "Button_CheckResponses"
 .Fill.ForeColor.RGB = RGB(0, 112, 192) ' Blue
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 .Placement = xlMoveAndSize
 .LockAspectRatio = msoTrue
 End With
 End If
 ' Send Follow-Up To All button
 If Not ButtonExists(ws, BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL) Then
 Set rng = ws.Range("D3:E3")
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
SetupModule - 3
 .TextFrame.Characters.Text = BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL
 .OnAction = "SendFollowUpToAll"
 .Name = "Button_SendFollowUpToAll"
 .Fill.ForeColor.RGB = RGB(255, 192, 0) ' Orange
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) ' Black text
 .Line.Visible = msoFalse
 .Placement = xlMoveAndSize
 .LockAspectRatio = msoTrue
 End With
 End If
 ' ------- Right Column Buttons -------
 ' Data Visualization button
 If Not ButtonExists(ws, BTN_CAPTION_DATA_VISUALIZATION) Then
 Set rng = ws.Range("F1:G1")
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_DATA_VISUALIZATION
 .OnAction = "CreateDataVisualization"
 .Name = "Button_DataVisualization"
 .Fill.ForeColor.RGB = RGB(112, 48, 160) ' Purple
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 .Placement = xlMoveAndSize
 .LockAspectRatio = msoTrue
 End With
 End If
 ' Import Data button
 If Not ButtonExists(ws, BTN_CAPTION_IMPORT_DATA) Then
 Set rng = ws.Range("F2:G2")
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_IMPORT_DATA
 .OnAction = "ImportData"
 .Name = "Button_ImportData"
 .Fill.ForeColor.RGB = RGB(0, 176, 240) ' Light Blue
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) ' Black text
 .Line.Visible = msoFalse
 .Placement = xlMoveAndSize
 .LockAspectRatio = msoTrue
 End With
 End If
 ' Export Data button
 If Not ButtonExists(ws, BTN_CAPTION_EXPORT_DATA) Then
 Set rng = ws.Range("F3:G3")
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_EXPORT_DATA
 .OnAction = "ExportData"
 .Name = "Button_ExportData"
 .Fill.ForeColor.RGB = RGB(0, 176, 240) ' Light Blue
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) ' Black text
 .Line.Visible = msoFalse
 .Placement = xlMoveAndSize
 .LockAspectRatio = msoTrue
 End With
 End If
 ' Close Tracker button
 If Not ButtonExists(ws, BTN_CAPTION_CLOSE_TRACKER) Then
 Set rng = ws.Range("F4:G4")
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_CLOSE_TRACKER
 .OnAction = "CloseTracker"
 .Name = "ButtonCloseTracker"
SetupModule - 4
 .Fill.ForeColor.RGB = RGB(192, 0, 0) ' Dark Red
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 .Placement = xlMoveAndSize
 .LockAspectRatio = msoTrue
 End With
 End If
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up buttons: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupButtons: " & Err.Description
End Sub
Private Sub SetupActivityLog(wsLog As Worksheet)
 On Error GoTo ErrorHandler
 With wsLog
 .Cells(1, 1).Value = "Date"
 .Cells(1, 2).Value = "Action"
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up activity log: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupActivityLog: " & Err.Description
End Sub
Private Sub SetupFollowUpMessages(wsFollowUp As Worksheet)
 On Error GoTo ErrorHandler
 With wsFollowUp
 .Cells(1, 1).Value = "Type"
 .Cells(1, 2).Value = "Message"
 .Cells(1, 3).Value = "Escalation Recipient" ' New column
 .Cells(2, 1).Value = "Follow-Up Message"
 .Cells(3, 1).Value = "Escalation Message"
 .Cells(2, 2).Value = "This is a follow-up. Please let us know if you need any further information."
 .Cells(3, 2).Value = "We have not received a response. This is an escalation email. Please respond at your earliest convenience."
 .Cells(3, 3).Value = "" ' Escalation recipient email, to be filled by user
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up follow-up messages: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupFollowUpMessages: " & Err.Description
End Sub
Private Sub SetupPreferences(wsPreferences As Worksheet)
 On Error GoTo ErrorHandler
 With wsPreferences
 .Cells(1, 1).Value = "Backup Path"
 .Cells(1, 2).Value = DEFAULT_BACKUP_PATH
 .Cells(2, 1).Value = "Backup Interval (Hours)"
 .Cells(2, 2).Value = BACKUP_INTERVAL_HOURS
 .Cells(3, 1).Value = "First Follow-Up Interval (Days)"
 .Cells(3, 2).Value = 1
 .Cells(4, 1).Value = "Escalation Interval (Days)"
 .Cells(4, 2).Value = 10
 .Cells(5, 1).Value = "Response Check Interval (Minutes)"
 .Cells(5, 2).Value = 1 ' Default 1 minute
 ' You can add more settings here as needed
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up preferences: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupPreferences: " & Err.Description
End Sub
Private Function ButtonExists(ws As Worksheet, caption As String) As Boolean
 Dim shp As Shape
SetupModule - 5
 ButtonExists = False
 For Each shp In ws.Shapes
 If shp.Type = msoShapeRectangle Or shp.Type = msoShapeRoundedRectangle Then
 If shp.TextFrame.Characters.Text = caption Then
 ButtonExists = True
 Exit Function
 End If
 End If
 Next shp
End Function
Public Sub FormatTrackerSheet(ws As Worksheet)
 On Error GoTo ErrorHandler
 ' Format Header Row (Row 4)
 With ws.Range("A4:J4") ' Ensure it includes all relevant columns up to Column J
 .Font.Bold = True
 .Interior.Color = RGB(0, 112, 192) ' Blue color
 .Font.Color = RGB(255, 255, 255) ' White text
 .HorizontalAlignment = xlCenter
 End With
 ' Auto-fit columns
 ws.Columns("A:J").AutoFit ' Update columns as needed
 ' Format Input Row
 With ws.Range("A2:B2")
 .Interior.Color = RGB(217, 225, 242) ' Light Blue
 .Font.Color = RGB(0, 0, 0) ' Black text
 End With
 ' Apply borders to all cells with data
 Dim lastRow As Long
 lastRow = GetLastDataRow(ws)
 If lastRow >= 4 Then
 With ws.Range("A4:J" & lastRow) ' Ensure it includes all relevant columns up to Column J
 .Borders.LineStyle = xlContinuous
 .Borders.Weight = xlThin
 End With
 End If
 ' Clear existing conditional formatting
 ws.Range("A5:J" & ws.Rows.Count).FormatConditions.Delete
 ' Apply conditional formatting to highlight rows with responses
 If lastRow >= 5 Then
 Dim dataRange As Range
 Set dataRange = ws.Range("A5:J" & lastRow)

 ' Highlight rows where "Remarks" is "Response Received"
 With dataRange
 .FormatConditions.Add Type:=xlExpression, Formula1:="=$D5=""Response Received"""
 With .FormatConditions(.FormatConditions.Count)
 .Interior.Color = RGB(198, 239, 206) ' Light Green
 End With
 End With

 ' Highlight rows where "Status" is "Operator Replied"
 With dataRange
 .FormatConditions.Add Type:=xlExpression, Formula1:="=$C5=""Operator Replied"""
 With .FormatConditions(.FormatConditions.Count)
 .Interior.Color = RGB(255, 255, 204) ' Light Yellow
 End With
 End With

 ' Highlight rows where "Status" is "You Replied"
 With dataRange
 .FormatConditions.Add Type:=xlExpression, Formula1:="=$C5=""You Replied"""
 With .FormatConditions(.FormatConditions.Count)
 .Interior.Color = RGB(204, 229, 255) ' Light Blue
 End With
 End With
 End If
SetupModule - 6
 ' Freeze panes to keep headers visible
 ws.Activate
 ws.Range("A5").Select
 ActiveWindow.FreezePanes = True
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while formatting the tracker sheet: " & Err.Description, vbExclamation
 Debug.Print "Error in FormatTrackerSheet: " & Err.Description
End Sub
UtilityModule - 1
Option Explicit
' Constants for Address Entry Types and Folders
Public Const olExchangeUserAddressEntry As Long = 0
Public Const olExchangeRemoteUserAddressEntry As Long = 5
Public Const olMail As Long = 43 ' Mail item class
Public Const olFolderInbox As Long = 6
Public Const olFolderSentMail As Long = 5
Public Const olFolderDrafts As Long = 16
Public Const olFolderDeletedItems As Long = 3
Public Const olFolderOutbox As Long = 4
Public Const olMailItem As Long = 0
Public responseCheckTimer As Date
Public Sub AddEmailToList()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim subject As String, recipients As String
 subject = Trim(ws.Cells(2, 1).Value)
 recipients = Trim(ws.Cells(2, 2).Value)
 If ValidateInput(subject, recipients) Then
 Dim nextRow As Long
 nextRow = GetNextAvailableRow(ws)
 ' Generate a unique ConversationID for this email
 Dim conversationID As String
 conversationID = CreateConversationID(subject)
 AddEmailEntry ws, nextRow, subject, recipients, conversationID
 LogAction "Added email: " & subject
 ClearInputFields ws
 ' Reformat the sheet to apply new styles
 FormatTrackerSheet ws
 End If
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in AddEmailToList: " & Err.Description, vbExclamation
 Debug.Print "Error in AddEmailToList: " & Err.Description
End Sub
Private Sub AddEmailEntry(ws As Worksheet, row As Long, subject As String, recipients As String, conversationID As String)
 Dim emailList As String
 emailList = ExtractEmails(recipients)
 With ws
 .Hyperlinks.Add Anchor:=.Cells(row, 1), Address:="", _
 SubAddress:="'Sheet1'!A" & row, _
 TextToDisplay:=subject, _
 ScreenTip:="Click to search conversation in Outlook"
 .Cells(row, 1).ClearComments
 .Cells(row, 1).AddComment subject
 .Cells(row, 1).Comment.Visible = False
 .Cells(row, 2).Value = emailList
 .Cells(row, 3).Value = "Followed Up"
 .Cells(row, 4).Value = "Awaiting Response"
 .Cells(row, 5).Value = Now ' Record date of follow-up
 .Cells(row, 8).Value = "" ' Initialize Last Response Date
 .Cells(row, 9).Value = 0 ' Initialize Follow-Up Count
 .Cells(row, 10).Value = conversationID ' Store ConversationID in Column J
 AddDeleteButton ws, row
 AddSendFollowUpButton ws, row
 End With
UtilityModule - 2
End Sub
Private Sub AddDeleteButton(ws As Worksheet, row As Long)
 Dim shp As Shape
 Dim rng As Range
 Set rng = ws.Cells(row, 6)
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_DELETE
 .OnAction = "DeleteRow"
 .Name = "Delete_Button_" & row
 .Placement = xlMoveAndSize
 .Fill.ForeColor.RGB = RGB(255, 0, 0) ' Red color
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 End With
End Sub
Private Sub AddSendFollowUpButton(ws As Worksheet, row As Long)
 Dim shp As Shape
 Dim rng As Range
 Set rng = ws.Cells(row, 7)
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_SEND_FOLLOW_UP
 .OnAction = "SendFollowUp"
 .Name = "FollowUp_Button_" & row
 .Placement = xlMoveAndSize
 .Fill.ForeColor.RGB = RGB(0, 176, 80) ' Green color
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 End With
End Sub
Public Sub deleteRow()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim shp As Shape
 Set shp = ws.Shapes(Application.Caller)
 Dim deleteRow As Long
 deleteRow = shp.TopLeftCell.row
 ' Delete related buttons
 DeleteButton "Delete_Button_" & deleteRow, ws
 DeleteButton "FollowUp_Button_" & deleteRow, ws
 ws.Rows(deleteRow).Delete
 ' Adjust button names for rows below
 Dim i As Long
 For i = deleteRow + 1 To GetLastDataRow(ws)
 On Error Resume Next
 ws.Shapes("Delete_Button_" & i).Name = "Delete_Button_" & (i - 1)
 ws.Shapes("FollowUp_Button_" & i).Name = "FollowUp_Button_" & (i - 1)
 On Error GoTo 0
 Next i
 LogAction "Deleted email entry from row " & deleteRow
 ' Reformat the sheet
 FormatTrackerSheet ws
 Exit Sub
ErrorHandler:
 MsgBox "Error deleting row. Please try again.", vbCritical
 Debug.Print "Error in DeleteRow: " & Err.Description
End Sub
Private Sub DeleteButton(buttonName As String, ws As Worksheet)
 Dim shp As Shape
UtilityModule - 3
 On Error Resume Next
 Set shp = ws.Shapes(buttonName)
 If Not shp Is Nothing Then
 shp.Delete
 End If
 On Error GoTo 0
End Sub
Private Sub ClearInputFields(ws As Worksheet)
 With ws
 .Cells(2, 1).Value = ""
 .Cells(2, 2).Value = ""
 End With
End Sub
Private Sub LogAction(action As String)
 Dim wsLog As Worksheet
 Set wsLog = ThisWorkbook.Sheets(SHEET_NAME_LOG)
 Dim nextLogRow As Long
 nextLogRow = wsLog.Cells(wsLog.Rows.Count, 1).End(xlUp).row + 1
 With wsLog
 .Cells(nextLogRow, 1).Value = Now
 .Cells(nextLogRow, 2).Value = action
 End With
End Sub
Private Function ExtractEmails(recipientStr As String) As String
 Dim regex As Object, matches As Object, match As Object
 Dim emailList As String
 Set regex = CreateObject("VBScript.RegExp")
 regex.Pattern = "\b[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\.[A-Z|a-z]{2,7}\b"
 regex.Global = True
 Set matches = regex.Execute(recipientStr)
 For Each match In matches
 emailList = emailList & match.Value & "; "
 Next match
 If Len(emailList) > 2 Then
 ExtractEmails = Left(emailList, Len(emailList) - 2)
 Else
 ExtractEmails = ""
 End If
End Function
Private Function CreateConversationID(subject As String) As String
 ' Generate a ConversationID based on subject and timestamp
 CreateConversationID = subject & "_" & Format(Now, "yyyymmddhhmmss")
End Function
Public Sub SearchOutlookConversations(subject As String)
 Dim olApp As Outlook.Application, olExplorer As Outlook.Explorer
 Dim searchText As String
 On Error Resume Next
 Set olApp = GetObject(, "Outlook.Application")
 If olApp Is Nothing Then
 Set olApp = New Outlook.Application
 olApp.Session.Logon "", "", False, False
 End If
 On Error GoTo 0
 If olApp Is Nothing Then
 MsgBox "Outlook is not installed or could not be started.", vbCritical
 Exit Sub
 End If
 ' Perform search
 searchText = "subject:""" & subject & """"
 Set olExplorer = olApp.ActiveExplorer
UtilityModule - 4
 If olExplorer Is Nothing Then
 Set olExplorer = olApp.Explorers.Add(olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox))
 olExplorer.Display
 End If
 olExplorer.Search searchText, olSearchScopeAllFolders ' Use Outlook constant
 olExplorer.Activate
End Sub
Public Sub HyperlinkClicked(Target As Hyperlink)
 Dim ws As Worksheet, subject As String
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 If Not Target.Range.Comment Is Nothing Then
 subject = Target.Range.Comment.Text
 Else
 subject = Target.Range.Text
 End If
 Call SearchOutlookConversations(subject)
End Sub
Public Sub CheckEmailResponses()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim lastRow As Long
 lastRow = GetLastDataRow(ws)
 Dim i As Long
 For i = 5 To lastRow ' Start from row 5, where data begins
 ' Check if the row has data in column A
 If Trim(ws.Cells(i, 1).Value) <> "" Then
 Dim subject As String, conversationID As String
 subject = ws.Cells(i, 1).Value
 conversationID = ws.Cells(i, 10).Value ' ConversationID in Column J
 Dim lastResponseDate As Date
 If IsDate(ws.Cells(i, 8).Value) Then
 lastResponseDate = ws.Cells(i, 8).Value
 Else
 lastResponseDate = #1/1/1900#
 End If
 Dim status As String
 status = DetermineEmailStatus(subject, lastResponseDate, conversationID)
 Select Case status
 Case "You Replied"
 ws.Cells(i, 3).Value = "You Replied"
 ws.Cells(i, 4).Value = "Awaiting Response"
 Case "Operator Replied"
 ws.Cells(i, 3).Value = "Operator Replied"
 ws.Cells(i, 4).Value = "Response Received"
 ws.Cells(i, 8).Value = Now ' Update Last Response Date
 LogAction "Response received for email: " & subject
 Case "No Change"
 ' Do nothing
 Case Else
 ' Handle other cases
 End Select
 End If
 Next i
 ' Reformat the sheet after updating statuses
 FormatTrackerSheet ws
 ' Call FollowUpEscalation to handle automatic follow-ups
 Call FollowUpEscalation
 Exit Sub
ErrorHandler:
UtilityModule - 5
 MsgBox "An error occurred in CheckEmailResponses: " & Err.Description, vbExclamation
 Debug.Print "Error in CheckEmailResponses: " & Err.Description
End Sub
Private Function DetermineEmailStatus(subject As String, lastResponseDate As Date, conversationID As String) As String
 Dim olApp As Outlook.Application
 Dim olNamespace As Outlook.Namespace
 Dim searchScope As String
 Dim filter As String
 Dim searchObj As Outlook.Search
 Dim SearchResults As Outlook.Results
 Dim latestMail As Outlook.MailItem
 Dim maxDate As Date
 Dim ownEmail As String
 Dim senderEmail As String
 Dim item As Object
 Dim clsSearch As ClsOutlookSearch
 Dim timeout As Date
 Dim timeoutSeconds As Integer
 On Error GoTo ErrorHandler
 Set olApp = New Outlook.Application
 Set olNamespace = olApp.GetNamespace("MAPI")
 ' Build the search filter using Subject matching and date filter
 Dim startDate As Date
 startDate = Now - 30 ' Adjust the number of days as needed
 ' DASL query
 filter = "urn:schemas:httpmail:subject LIKE '%" & Replace(subject, "'", "''") & "%' AND " & _
 "urn:schemas:httpmail:datereceived >= '" & Format(startDate, "yyyy-mm-dd") & "'"
 ' Initialize the class to handle AdvancedSearch events
 Set clsSearch = New ClsOutlookSearch
 clsSearch.SearchComplete = False
 ' Start the AdvancedSearch
 searchScope = "'Inbox','Sent Items','Drafts','Deleted Items','Outbox'"
 Set searchObj = olApp.AdvancedSearch(searchScope, filter, True, "EmailTrackerSearch")
 ' Wait for the search to complete or timeout after specified seconds
 timeoutSeconds = 30 ' Increased timeout duration
 timeout = Now + TimeSerial(0, 0, timeoutSeconds)
 Do While clsSearch.SearchComplete = False
 DoEvents
 If Now > timeout Then
 Debug.Print "Search timed out."
 DetermineEmailStatus = "No Change"
 Exit Function
 End If
 Loop
 Set SearchResults = clsSearch.SearchResults
 ' Initialize variables
 maxDate = lastResponseDate
 Set latestMail = Nothing
 ' Loop through searchResults
 If SearchResults.Count > 0 Then
 For Each item In SearchResults
 If TypeName(item) = "MailItem" Then
 Dim itemDate As Date
 itemDate = item.ReceivedTime
 If itemDate > maxDate Then
 maxDate = itemDate
 Set latestMail = item
 End If
 End If
 Next item
UtilityModule - 6
 End If
 If latestMail Is Nothing Then
 DetermineEmailStatus = "No Change"
 Exit Function
 End If
 ' Get own email address
 ownEmail = GetSMTPAddress(olNamespace.CurrentUser.AddressEntry)
 ' Get sender's email address
 senderEmail = GetSMTPAddress(latestMail.Sender)
 If StrComp(senderEmail, ownEmail, vbTextCompare) = 0 Then
 ' Latest email is from us
 DetermineEmailStatus = "You Replied"
 Else
 ' Latest email is from recipient
 DetermineEmailStatus = "Operator Replied"
 End If
 Exit Function
ErrorHandler:
 Debug.Print "Error in DetermineEmailStatus: " & Err.Description
 DetermineEmailStatus = "No Change"
End Function
Private Function GetSMTPAddress(olAddressEntry As Outlook.AddressEntry) As String
 Dim senderEmailAddress As String
 On Error Resume Next
 If olAddressEntry.AddressEntryUserType = olExchangeUserAddressEntry Or _
 olAddressEntry.AddressEntryUserType = olExchangeRemoteUserAddressEntry Then
 ' Exchange user
 senderEmailAddress = olAddressEntry.GetExchangeUser().PrimarySmtpAddress
 If senderEmailAddress = "" Then
 ' Try getting from Exchange remote user
 senderEmailAddress = olAddressEntry.GetExchangeRemoteUser().PrimarySmtpAddress
 End If
 Else
 ' Other types (POP3, IMAP, SMTP)
 senderEmailAddress = olAddressEntry.Address
 End If
 If senderEmailAddress = "" Then
 senderEmailAddress = olAddressEntry.Address
 End If
 GetSMTPAddress = senderEmailAddress
 On Error GoTo 0
End Function
Private Function ValidateInput(subject As String, recipients As String) As Boolean
 If Trim(subject) = "" Or Trim(recipients) = "" Then
 MsgBox "Please enter both subject and recipients!", vbExclamation
 ValidateInput = False
 Else
 ValidateInput = True
 End If
End Function
Public Sub SendEmail(recipients As String, subject As String, body As String)
 Dim olApp As Outlook.Application, olMail As Outlook.MailItem
 On Error Resume Next
 Set olApp = GetObject(, "Outlook.Application")
 If olApp Is Nothing Then
 Set olApp = New Outlook.Application
 olApp.Session.Logon "", "", False, False
 End If
 On Error GoTo 0
 If olApp Is Nothing Then
 MsgBox "Outlook is not installed or could not be started.", vbCritical
UtilityModule - 7
 Exit Sub
 End If
 Set olMail = olApp.CreateItem(olMailItem)
 With olMail
 .To = recipients
 .subject = subject
 .body = body
 .Send
 End With
 ' Clean up
 Set olMail = Nothing
 Set olApp = Nothing
End Sub
Public Sub SendFollowUp()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim shp As Shape
 Set shp = ws.Shapes(Application.Caller)
 Dim row As Long
 row = shp.TopLeftCell.row
 Dim lastFollowUpDate As Date
 If IsDate(ws.Cells(row, 5).Value) Then
 lastFollowUpDate = ws.Cells(row, 5).Value
 Else
 lastFollowUpDate = #1/1/1900#
 End If
 Dim followUpIntervalDays As Integer
 followUpIntervalDays = GetPreference("First Follow-Up Interval (Days)")
 If IsEmpty(followUpIntervalDays) Or Not IsNumeric(followUpIntervalDays) Then
 followUpIntervalDays = 1
 End If
 If DateDiff("d", lastFollowUpDate, Now) < followUpIntervalDays Then
 MsgBox "A follow-up has already been sent within the specified interval for this email.", vbInformation
 Exit Sub
 End If
 Dim subject As String, recipients As String
 subject = ws.Cells(row, 1).Value
 recipients = ws.Cells(row, 2).Value
 Dim wsFollowUp As Worksheet
 Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)
 Dim followUpMessage As String
 followUpMessage = wsFollowUp.Cells(2, 2).Value
 SendEmail recipients, subject, followUpMessage
 ws.Cells(row, 5).Value = Now
 ws.Cells(row, 3).Value = "Followed Up"
 ws.Cells(row, 4).Value = "Awaiting Response"
 ws.Cells(row, 9).Value = ws.Cells(row, 9).Value + 1 ' Increment Follow-Up Count
 LogAction "Sent follow-up for email: " & subject
 MsgBox "Follow-up email sent for: " & subject, vbInformation
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in SendFollowUp: " & Err.Description, vbExclamation
 Debug.Print "Error in SendFollowUp: " & Err.Description
End Sub
Public Sub StartResponseCheckTimer()
 Dim intervalMinutes As Double
 intervalMinutes = GetPreference("Response Check Interval (Minutes)")
 If intervalMinutes <= 0 Then intervalMinutes = 1 ' Default to 1 minute
UtilityModule - 8
 responseCheckTimer = Now + TimeSerial(0, intervalMinutes, 0)
 Application.OnTime responseCheckTimer, "CheckEmailResponses"
End Sub
Public Sub StopResponseCheckTimer()
 On Error Resume Next
 Application.OnTime responseCheckTimer, "CheckEmailResponses", , False
 On Error GoTo 0
End Sub
Public Sub SendFollowUpToAll()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim lastRow As Long
 lastRow = GetLastDataRow(ws)
 Dim i As Long
 For i = 5 To lastRow
 If ws.Cells(i, 1).Value <> "" Then
 ' Check if follow-up is needed
 Dim lastFollowUpDate As Date
 If IsDate(ws.Cells(i, 5).Value) Then
 lastFollowUpDate = ws.Cells(i, 5).Value
 Else
 lastFollowUpDate = #1/1/1900#
 End If
 Dim followUpIntervalDays As Integer
 followUpIntervalDays = GetPreference("First Follow-Up Interval (Days)")
 If IsEmpty(followUpIntervalDays) Or Not IsNumeric(followUpIntervalDays) Then
 followUpIntervalDays = 1
 End If
 If DateDiff("d", lastFollowUpDate, Now) >= followUpIntervalDays Then
 ' Send follow-up
 Dim subject As String, recipients As String
 subject = ws.Cells(i, 1).Value
 recipients = ws.Cells(i, 2).Value
 Dim wsFollowUp As Worksheet
 Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)
 Dim followUpMessage As String
 followUpMessage = wsFollowUp.Cells(2, 2).Value
 SendEmail recipients, subject, followUpMessage
 ws.Cells(i, 5).Value = Now
 ws.Cells(i, 3).Value = "Followed Up"
 ws.Cells(i, 4).Value = "Awaiting Response"
 ws.Cells(i, 9).Value = ws.Cells(i, 9).Value + 1 ' Increment Follow-Up Count
 LogAction "Sent follow-up for email: " & subject
 End If
 End If
 Next i
 MsgBox "Follow-up emails sent to all pending items.", vbInformation
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in SendFollowUpToAll: " & Err.Description, vbExclamation
 Debug.Print "Error in SendFollowUpToAll: " & Err.Description
End Sub
Public Sub FollowUpEscalation()
 On Error GoTo ErrorHandler
 Dim ws As Worksheet, wsFollowUp As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)
 Dim lastRow As Long
 lastRow = GetLastDataRow(ws)
 Dim escalationMessage As String
UtilityModule - 9
 escalationMessage = wsFollowUp.Cells(3, 2).Value
 Dim escalationRecipient As String
 escalationRecipient = wsFollowUp.Cells(3, 3).Value
 Dim escalationInterval As Integer
 escalationInterval = GetPreference("Escalation Interval (Days)")
 If IsEmpty(escalationInterval) Or Not IsNumeric(escalationInterval) Then
 escalationInterval = 10
 End If
 Dim followUpIntervalDays As Integer
 followUpIntervalDays = GetPreference("First Follow-Up Interval (Days)")
 If IsEmpty(followUpIntervalDays) Or Not IsNumeric(followUpIntervalDays) Then
 followUpIntervalDays = 1
 End If
 Dim i As Long
 For i = 5 To lastRow
 If ws.Cells(i, 1).Value <> "" Then
 Dim status As String
 status = ws.Cells(i, 3).Value
 Dim remarks As String
 remarks = ws.Cells(i, 4).Value
 Dim lastFollowUpDate As Date
 If IsDate(ws.Cells(i, 5).Value) Then
 lastFollowUpDate = ws.Cells(i, 5).Value
 Else
 lastFollowUpDate = #1/1/1900#
 End If
 Dim followUpCount As Integer
 followUpCount = ws.Cells(i, 9).Value
 Dim daysSinceFollowUp As Integer
 daysSinceFollowUp = DateDiff("d", lastFollowUpDate, Now)
 ' Check if it's time to send a follow-up
 If remarks = "Awaiting Response" Then
 If daysSinceFollowUp >= followUpIntervalDays Then
 ' Send follow-up
 SendFollowUpForRow i
 ws.Cells(i, 3).Value = "Followed Up"
 ws.Cells(i, 4).Value = "Awaiting Response"
 ws.Cells(i, 5).Value = Now ' Update last follow-up date
 ws.Cells(i, 9).Value = followUpCount + 1 ' Increment Follow-Up Count
 LogAction "Automatically sent follow-up for email: " & ws.Cells(i, 1).Value
 End If
 ' Optionally, escalate after a certain number of follow-ups or days
 If followUpCount >= 5 Or daysSinceFollowUp >= escalationInterval Then
 If escalationRecipient <> "" Then
 ForwardLatestResponse ws.Cells(i, 1).Value, escalationMessage, escalationRecipient
 ws.Cells(i, 3).Value = "Escalated"
 ws.Cells(i, 4).Value = "Awaiting Response"
 LogAction "Escalated email: " & ws.Cells(i, 1).Value
 End If
 End If
 End If
 End If
 Next i
 ' Reformat the sheet after updating statuses
 FormatTrackerSheet ws
 ' Restart the timer for the next check
 Call StartResponseCheckTimer
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in FollowUpEscalation: " & Err.Description, vbExclamation
 Debug.Print "Error in FollowUpEscalation: " & Err.Description
UtilityModule - 10
End Sub
Private Sub SendFollowUpForRow(row As Long)
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim subject As String, recipients As String
 subject = ws.Cells(row, 1).Value
 recipients = ws.Cells(row, 2).Value
 Dim wsFollowUp As Worksheet
 Set wsFollowUp = ThisWorkbook.Sheets(SHEET_NAME_FOLLOW_UP)
 Dim followUpMessage As String
 followUpMessage = wsFollowUp.Cells(2, 2).Value
 SendEmail recipients, subject, followUpMessage
End Sub
Private Sub ForwardLatestResponse(subject As String, body As String, escalationRecipient As String)
 Dim olApp As Outlook.Application
 Dim olNamespace As Outlook.Namespace
 Dim searchScope As String
 Dim filter As String
 Dim searchObj As Outlook.Search
 Dim SearchResults As Outlook.Results
 Dim latestMail As Outlook.MailItem
 Dim maxDate As Date
 Dim item As Object
 Dim clsSearch As ClsOutlookSearch
 Dim timeout As Date
 Dim timeoutSeconds As Integer
 On Error GoTo ErrorHandler
 Set olApp = New Outlook.Application
 Set olNamespace = olApp.GetNamespace("MAPI")
 ' Build the search filter using Subject matching and date filter
 Dim startDate As Date
 startDate = Now - 30 ' Adjust as needed
 filter = "urn:schemas:httpmail:subject LIKE '%" & Replace(subject, "'", "''") & "%' AND " & _
 "urn:schemas:httpmail:datereceived >= '" & Format(startDate, "yyyy-mm-dd") & "'"
 ' Initialize the class to handle AdvancedSearch events
 Set clsSearch = New ClsOutlookSearch
 clsSearch.SearchComplete = False
 ' Start the AdvancedSearch
 searchScope = "'Inbox','Sent Items','Drafts','Deleted Items','Outbox'"
 Set searchObj = olApp.AdvancedSearch(searchScope, filter, True, "EmailTrackerSearch_Forward")
 ' Wait for the search to complete or timeout after specified seconds
 timeoutSeconds = 30 ' Increased timeout duration
 timeout = Now + TimeSerial(0, 0, timeoutSeconds)
 Do While clsSearch.SearchComplete = False
 DoEvents
 If Now > timeout Then
 Debug.Print "Search timed out."
 Exit Do
 End If
 Loop
 Set SearchResults = clsSearch.SearchResults
 ' Initialize variables
 maxDate = #1/1/1900#
 Set latestMail = Nothing
 ' Loop through searchResults
 If SearchResults.Count > 0 Then
 For Each item In SearchResults
UtilityModule - 11
 If TypeName(item) = "MailItem" Then
 Dim itemDate As Date
 itemDate = item.ReceivedTime
 If itemDate > maxDate Then
 maxDate = itemDate
 Set latestMail = item
 End If
 End If
 Next item
 End If
 If Not latestMail Is Nothing Then
 Dim olForward As Outlook.MailItem
 Set olForward = latestMail.Forward
 With olForward
 .To = escalationRecipient
 .body = body & vbCrLf & .body
 .Send
 End With
 Else
 ' No email to forward, send new email
 Dim olMail As Outlook.MailItem
 Set olMail = olApp.CreateItem(olMailItem)
 With olMail
 .To = escalationRecipient
 .subject = "Escalation: " & subject
 .body = body
 .Send
 End With
 End If
 ' Clean up
 Set olNamespace = Nothing
 Set olApp = Nothing
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in ForwardLatestResponse: " & Err.Description, vbExclamation
 Debug.Print "Error in ForwardLatestResponse: " & Err.Description
End Sub
' Close Tracker subroutine
Public Sub CloseTracker()
 On Error GoTo ErrorHandler
 ThisWorkbook.Save
 Application.Quit
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while closing the tracker: " & Err.Description, vbExclamation
 Debug.Print "Error in CloseTracker: " & Err.Description
End Sub
ClsOutlookSearch - 1
Option Explicit
Public WithEvents olAdvancedSearch As Outlook.Application
Public SearchComplete As Boolean
Public SearchResults As Outlook.Results
Private Sub Class_Initialize()
 Set olAdvancedSearch = Outlook.Application
End Sub
Private Sub olAdvancedSearch_AdvancedSearchComplete(ByVal SearchObject As Outlook.Search)
 Set SearchResults = SearchObject.Results
 SearchComplete = True
End Sub