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
 Resume Next
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
 Debug.Print "Error in Worksheet_BeforeDoubleClick: " & Err.Description
 Resume Next
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
 Resume Next
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
 Resume Next
End Sub
DataVisualizationModule - 1
Option Explicit
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"
 End If
 On Error GoTo 0
 ' Clear existing charts
 chartSheet.Cells.Clear
 CreateStatusChart chartSheet, ws
 CreateResponseChart chartSheet, ws
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred in CreateDataVisualization: " & Err.Description, vbExclamation
 Debug.Print "Error in CreateDataVisualization: " & Err.Description
 Resume Next
End Sub
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 ' Assuming Status is in Column C
 If statusCounts.Exists(status) Then
 statusCounts(status) = statusCounts(status) + 1
 Else
 statusCounts(status) = 1
 End If
 Next i
 ' Prepare data for chart
 Dim chartData As Range
 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:
DataVisualizationModule - 2
 MsgBox "An error occurred in CreateStatusChart: " & Err.Description, vbExclamation
 Debug.Print "Error in CreateStatusChart: " & Err.Description
 Resume Next
End Sub
Sub CreateResponseChart(chartSheet As Worksheet, ws As Worksheet)
 On Error GoTo ErrorHandler
 Dim daysSinceResponse As Object
 Set daysSinceResponse = 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 ' Assuming Last Response Date is in Column H
 Dim days As Long
 days = DateDiff("d", ws.Cells(i, 8).Value, Now)
 If daysSinceResponse.Exists(days) Then
 daysSinceResponse(days) = daysSinceResponse(days) + 1
 Else
 daysSinceResponse(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 daysSinceResponse.Keys
 chartSheet.Cells(index, 1).Value = key
 chartSheet.Cells(index, 2).Value = daysSinceResponse(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
 Resume Next
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
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)
 ws.Copy
 With ActiveWorkbook
 .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
 Resume Next
End Sub
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)
 Dim importWs As Worksheet
 Set importWs = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
 importWs.Name = "ImportTemp"
 With importWs.QueryTables.Add(Connection:="TEXT;" & importFilePath, Destination:=importWs.Cells(1, 1))
 .TextFileParseType = xlDelimited
 .TextFileCommaDelimiter = True
 .Refresh BackgroundQuery:=False
 End With
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim lastRow As Long
 lastRow = GetNextAvailableRow(ws) - 1
 Dim importLastRow As Long
 importLastRow = GetLastDataRow(importWs)
 ws.Range("A" & (lastRow + 1) & ":I" & (lastRow + importLastRow - 1)).Value = importWs.Range("A2:I" & importLastRow).Value
 Application.DisplayAlerts = False
ImportExportModule - 2
 importWs.Delete
 Application.DisplayAlerts = True
 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
 Resume Next
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 BACKUP_INTERVAL_HOURS As Integer = 1
Public Const DEFAULT_BACKUP_PATH As String = "C:\Backups\"
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
 Resume Next
End Sub
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
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"
 .Cells(4, 6).Value = "Delete"
 .Cells(4, 7).Value = "Send Follow-Up"
 .Cells(4, 8).Value = "Last Response Date" ' Column H
SetupModule - 2
 .Cells(4, 9).Value = "Follow-Up Count" ' Column I
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up headers: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupHeaders: " & Err.Description
 Resume Next
End Sub
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
 Resume Next
End Sub
Sub SetupButtons(ws As Worksheet)
 On Error GoTo ErrorHandler
 Dim shp As Shape
 Dim rng As Range
 ' Add To List button
 If Not ButtonExists(ws, BTN_CAPTION_ADD) Then
 Set rng = ws.Range("D1:E1") ' Adjust the cell range for the button
 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
 .TextFrame.HorizontalAlignment = xlHAlignCenter
 .TextFrame.VerticalAlignment = xlVAlignCenter
 End With
 End If
 ' Check Responses button
 If Not ButtonExists(ws, BTN_CAPTION_CHECK_RESPONSES) Then
 Set rng = ws.Range("D2:E2") ' Adjust the cell range for the button
 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
 .TextFrame.HorizontalAlignment = xlHAlignCenter
 .TextFrame.VerticalAlignment = xlVAlignCenter
 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") ' Adjust the cell range for the button
 Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, rng.Left, rng.Top, rng.Width, rng.Height)
 With shp
 .TextFrame.Characters.Text = BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL
 .OnAction = "SendFollowUpToAll"
SetupModule - 3
 .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
 .TextFrame.HorizontalAlignment = xlHAlignCenter
 .TextFrame.VerticalAlignment = xlVAlignCenter
 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
 Resume Next
End Sub
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
 Resume Next
End Sub
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
 Resume Next
End Sub
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
 End With
 Exit Sub
ErrorHandler:
 MsgBox "An error occurred while setting up preferences: " & Err.Description, vbExclamation
 Debug.Print "Error in SetupPreferences: " & Err.Description
SetupModule - 4
 Resume Next
End Sub
Function ButtonExists(ws As Worksheet, caption As String) As Boolean
 Dim shp As Shape
 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
Sub FormatTrackerSheet(ws As Worksheet)
 On Error Resume Next
 ' Format Header Row (Row 4)
 With ws.Range("A4:I4") ' Ensure it includes all relevant columns
 .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:I").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:I" & lastRow) ' Ensure it includes all relevant columns
 .Borders.LineStyle = xlContinuous
 .Borders.Weight = xlThin
 End With
 End If
 ' Clear existing conditional formatting
 ws.Range("A5:I" & 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:I" & 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"""
SetupModule - 5
 With .FormatConditions(.FormatConditions.Count)
 .Interior.Color = RGB(204, 229, 255) ' Light Blue
 End With
 End With
 End If
 ' Freeze panes to keep headers visible
 ws.Activate
 ws.Range("A5").Select
 ActiveWindow.FreezePanes = True
 On Error GoTo 0
End Sub
UtilityModule - 1
Option Explicit
' Constants for Address Entry Types and Folders
Const olExchangeUserAddressEntry = 0
Const olExchangeRemoteUserAddressEntry = 5
Const olFolderInbox = 6
Const olFolderSentMail = 5
Dim responseCheckTimer As Date
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)
 AddEmailEntry ws, nextRow, subject, recipients
 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
 Resume Next
End Sub
Sub AddEmailEntry(ws As Worksheet, row As Long, subject As String, recipients 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
 AddDeleteButton ws, row
 AddSendFollowUpButton ws, row
 End With
End Sub
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"
UtilityModule - 2
 .Name = "Delete_Button_" & row
 .Placement = xlMoveAndSize
 ' Format the button
 .Fill.ForeColor.RGB = RGB(255, 0, 0) ' Red color
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 .TextFrame.HorizontalAlignment = xlHAlignCenter
 .TextFrame.VerticalAlignment = xlVAlignCenter
 End With
End Sub
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
 ' Format the button
 .Fill.ForeColor.RGB = RGB(0, 176, 80) ' Green color
 .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' White text
 .Line.Visible = msoFalse
 .TextFrame.HorizontalAlignment = xlHAlignCenter
 .TextFrame.VerticalAlignment = xlVAlignCenter
 End With
End Sub
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
 Resume Next
End Sub
Sub DeleteButton(buttonName As String, ws As Worksheet)
 Dim shp As Shape
 On Error Resume Next
 Set shp = ws.Shapes(buttonName)
 If Not shp Is Nothing Then
UtilityModule - 3
 shp.Delete
 End If
 On Error GoTo 0
End Sub
Sub ClearInputFields(ws As Worksheet)
 With ws
 .Cells(2, 1).Value = ""
 .Cells(2, 2).Value = ""
 End With
End Sub
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
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
Sub SearchOutlookConversations(subject As String)
 Dim olApp As Object, olExplorer As Object
 Dim searchText As String
 On Error Resume Next
 Set olApp = GetObject(, "Outlook.Application")
 If olApp Is Nothing Then
 Set olApp = CreateObject("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
 If olExplorer Is Nothing Then
 Set olExplorer = olApp.Explorers.Add(olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox))
 olExplorer.Display
 End If
 olExplorer.Search searchText, 2 ' 2 = olSearchScopeAllFolders
 olExplorer.Activate
End Sub
UtilityModule - 4
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
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, recipients As String
 subject = ws.Cells(i, 1).Value
 recipients = ws.Cells(i, 2).Value
 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)
 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 "Error"
 ' Handle error if needed
 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:
 MsgBox "An error occurred in CheckEmailResponses: " & Err.Description, vbExclamation
 Debug.Print "Error in CheckEmailResponses: " & Err.Description
 Resume Next
End Sub
Function DetermineEmailStatus(subject As String, lastResponseDate As Date) As String
 Dim olApp As Object, olNamespace As Object, olInbox As Object, olSentItems As Object
 Dim olItems As Object, olSentItemsFiltered As Object
UtilityModule - 5
 Dim filter As String
 Dim latestMail As Object
 Dim maxDate As Date
 On Error Resume Next
 Set olApp = GetObject(, "Outlook.Application")
 If olApp Is Nothing Then
 Set olApp = CreateObject("Outlook.Application")
 olApp.Session.Logon "", "", False, False
 End If
 On Error GoTo 0
 If olApp Is Nothing Then
 DetermineEmailStatus = "Error"
 Exit Function
 End If
 Set olNamespace = olApp.GetNamespace("MAPI")
 ' Build filter for subject
 filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " ci_phrasematch '" & subject & "'"
 ' Search Inbox
 Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)
 Set olItems = olInbox.Items.Restrict(filter)
 ' Search Sent Items
 Set olSentItems = olNamespace.GetDefaultFolder(olFolderSentMail)
 Set olSentItemsFiltered = olSentItems.Items.Restrict(filter)
 ' Combine Inbox and Sent Items
 Dim combinedItems As Collection
 Set combinedItems = New Collection
 Dim item As Object
 For Each item In olItems
 combinedItems.Add item
 Next item
 For Each item In olSentItemsFiltered
 combinedItems.Add item
 Next item
 ' Find the latest email
 If combinedItems.Count > 0 Then
 maxDate = #1/1/1900#
 For Each item In combinedItems
 Dim mailDate As Date
 If item.SentOn > item.ReceivedTime Then
 mailDate = item.SentOn
 Else
 mailDate = item.ReceivedTime
 End If
 If mailDate > maxDate Then
 maxDate = mailDate
 Set latestMail = item
 End If
 Next item
 If maxDate > lastResponseDate Then
 Dim senderEmail As String
 senderEmail = GetSMTPAddress(latestMail.Sender)
 Dim ownEmail As String
 ownEmail = GetSMTPAddress(olNamespace.CurrentUser.AddressEntry)
 If StrComp(senderEmail, ownEmail, vbTextCompare) = 0 Then
 ' Latest email is from us
 DetermineEmailStatus = "You Replied"
 Else
 ' Latest email is from recipient
UtilityModule - 6
 DetermineEmailStatus = "Operator Replied"
 End If
 Else
 DetermineEmailStatus = "No Change"
 End If
 Else
 DetermineEmailStatus = "No Change"
 End If
 ' Clean up
 Set olItems = Nothing
 Set olSentItemsFiltered = Nothing
 Set olInbox = Nothing
 Set olSentItems = Nothing
 Set olNamespace = Nothing
 Set olApp = Nothing
End Function
Function GetSMTPAddress(olAddressEntry As Object) 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
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
Sub SendEmail(recipients As String, subject As String, body As String)
 Dim olApp As Object, olMail As Object
 On Error Resume Next
 Set olApp = GetObject(, "Outlook.Application")
 If olApp Is Nothing Then
 Set olApp = CreateObject("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
 Set olMail = olApp.CreateItem(0)
 With olMail
 .To = recipients
 .subject = subject
 .body = body
 .Send
 End With
UtilityModule - 7
 ' Clean up
 Set olMail = Nothing
 Set olApp = Nothing
End Sub
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
 Resume Next
End Sub
Sub StartResponseCheckTimer()
 Dim intervalMinutes As Double
 intervalMinutes = GetPreference("Response Check Interval (Minutes)")
 If intervalMinutes <= 0 Then intervalMinutes = 1 ' Default to 1 minute
 responseCheckTimer = Now + TimeSerial(0, intervalMinutes, 0)
 Application.OnTime responseCheckTimer, "CheckEmailResponses"
End Sub
Sub StopResponseCheckTimer()
 On Error Resume Next
 Application.OnTime responseCheckTimer, "CheckEmailResponses", , False
 On Error GoTo 0
End Sub
UtilityModule - 8
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
 Resume Next
End Sub
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
 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
UtilityModule - 9
 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
 Resume Next
End Sub
Sub SendFollowUpForRow(row As Long)
 Dim ws As Worksheet
 Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)
 Dim subject As String, recipients As String
UtilityModule - 10
 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
Sub ForwardLatestResponse(subject As String, body As String, escalationRecipient As String)
 Dim olApp As Object, olNamespace As Object, olInbox As Object, olSentItems As Object
 Dim olItems As Object, latestMail As Object
 Dim filter As String
 On Error Resume Next
 Set olApp = GetObject(, "Outlook.Application")
 If olApp Is Nothing Then
 Set olApp = CreateObject("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
 Set olNamespace = olApp.GetNamespace("MAPI")
 ' Build filter for subject
 filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " ci_phrasematch '" & subject & "'"
 ' Search Inbox
 Set olInbox = olNamespace.GetDefaultFolder(olFolderInbox)
 Set olItems = olInbox.Items.Restrict(filter)
 ' Search Sent Items
 Set olSentItems = olNamespace.GetDefaultFolder(olFolderSentMail)
 Set olSentItemsFiltered = olSentItems.Items.Restrict(filter)
 ' Combine Inbox and Sent Items
 Dim combinedItems As Collection
 Set combinedItems = New Collection
 Dim item As Object
 For Each item In olItems
 combinedItems.Add item
 Next item
 For Each item In olSentItemsFiltered
 combinedItems.Add item
 Next item
 ' Find the latest email
 If combinedItems.Count > 0 Then
 Set latestMail = combinedItems(1)
 Dim maxDate As Date
 maxDate = #1/1/1900#
 For Each item In combinedItems
 Dim mailDate As Date
 If item.SentOn > item.ReceivedTime Then
 mailDate = item.SentOn
 Else
 mailDate = item.ReceivedTime
 End If
 If mailDate > maxDate Then
 maxDate = mailDate
 Set latestMail = item
 End If
UtilityModule - 11
 Next item
 If Not latestMail Is Nothing Then
 Dim olForward As Object
 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 Object
 Set olMail = olApp.CreateItem(0)
 With olMail
 .To = escalationRecipient
 .subject = "Escalation: " & subject
 .body = body
 .Send
 End With
 End If
 Else
 ' No matching email found, send new escalation email
 Dim olMail As Object
 Set olMail = olApp.CreateItem(0)
 With olMail
 .To = escalationRecipient
 .subject = "Escalation: " & subject
 .body = body
 .Send
 End With
 End If
 ' Clean up
 Set olForward = Nothing
 Set olItems = Nothing
 Set olSentItemsFiltered = Nothing
 Set olInbox = Nothing
 Set olSentItems = Nothing
 Set olNamespace = Nothing
 Set olApp = Nothing
End Sub