You are Qwen, a very expert coding professional who always understands the request and give the best solution. You always think deeply first before giving answer to make sure that youll give the best answer. You are a helpful assistant.


Analyze this code

For sheet1

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, vbExclamation
    Debug.Print "Error in Worksheet_BeforeDoubleClick: " & Err.Description
    Resume Next
End Sub

For thisworkbook

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


for datavalidationmodule

Option Explicit

Sub CreateDataVisualization()
    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
End Sub

Sub CreateStatusChart(chartSheet As Worksheet, ws As Worksheet)
    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:=400, Height:=300)
    With cht.Chart
        .SetSourceData Source:=chartSheet.Range("A1:B" & index - 1)
        .ChartType = xlPie
        .HasTitle = True
        .ChartTitle.Text = "Email Status Distribution"
    End With
End Sub

Sub CreateResponseChart(chartSheet As Worksheet, ws As Worksheet)
    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(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:=400, 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"
    End With
End Sub

For herlpermodule

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


for importexportmodule

Option Explicit

Sub ExportData()
    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
End Sub

Sub ImportData()
    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
            importWs.Delete
            Application.DisplayAlerts = True

            MsgBox "Data imported successfully!", vbInformation
        End If
    End With
End Sub


For setupmodule

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
        .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
    ' Add To List button
    If Not ButtonExists(ws, BTN_CAPTION_ADD) Then
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 450, 10, 150, 20) ' Adjust position as needed
        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
        End With
    End If
    ' Check Responses button
    If Not ButtonExists(ws, BTN_CAPTION_CHECK_RESPONSES) Then
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 450, 40, 150, 20) ' Adjust position as needed
        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
        End With
    End If
    ' Send Follow-Up To All button
    If Not ButtonExists(ws, BTN_CAPTION_SEND_FOLLOW_UP_TO_ALL) Then
        Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, 450, 70, 150, 20) ' Adjust position as needed
        With shp
            .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
        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
    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)
    With ws.Range("A4:I" & lastRow) ' Ensure it includes all relevant columns
        .Borders.LineStyle = xlContinuous
        .Borders.Weight = xlThin
    End With

    ' Clear existing conditional formatting
    ws.Range("A5:I" & ws.Rows.Count).FormatConditions.Delete

    ' Apply conditional formatting to highlight rows with responses
    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"""
        With .FormatConditions(.FormatConditions.Count)
            .Interior.Color = RGB(204, 229, 255) ' Light Blue
        End With
    End With

    ' Freeze panes to keep headers visible
    ws.Activate
    ws.Range("A5").Select
    ActiveWindow.FreezePanes = True

    On Error GoTo 0
End Sub

for utiliymodule

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()
    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
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"
        .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 = xlCenter
        .TextFrame.VerticalAlignment = xlCenter
    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 = xlCenter
        .TextFrame.VerticalAlignment = xlCenter
    End With
End Sub

Sub deleteRow()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(SHEET_NAME_MAIN)

    Dim shp As Shape
    On Error GoTo ErrHandler
    Set shp = ws.Shapes(Application.Caller)

    Dim deleteRow As Long
    deleteRow = shp.TopLeftCell.row

    ws.Rows(deleteRow).Delete
    ' Delete related buttons
    DeleteButton "Delete_Button_" & deleteRow, ws
    DeleteButton "FollowUp_Button_" & deleteRow, ws

    ' Adjust button names for rows below
    Dim i As Long
    For i = deleteRow To GetLastDataRow(ws)
        On Error Resume Next
        ws.Shapes("Delete_Button_" & (i + 1)).Name = "Delete_Button_" & i
        ws.Shapes("FollowUp_Button_" & (i + 1)).Name = "FollowUp_Button_" & i
        On Error GoTo 0
    Next i

    LogAction "Deleted email entry from row " & deleteRow

    ' Reformat the sheet
    FormatTrackerSheet ws

    Exit Sub

ErrHandler:
    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
        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 = GetNextAvailableRow(wsLog)

    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

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()
    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
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
    Dim filter As String
    Dim latestMail As Object
    Dim maxDate As Date
    Dim direction 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
        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
                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

    ' Clean up
    Set olMail = Nothing
    Set olApp = Nothing
End Sub

Sub SendFollowUp()
    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

    If DateDiff("d", lastFollowUpDate, Now) = 0 Then
        MsgBox "A follow-up has already been sent today 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
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

Sub SendFollowUpToAll()
    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

            If DateDiff("d", lastFollowUpDate, Now) >= 1 Then ' Only if a day has passed
                ' 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
End Sub

Sub FollowUpEscalation()
    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
    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 status = "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
                    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
    Next i

    ' Reformat the sheet after updating statuses
    FormatTrackerSheet ws

    ' Restart the timer for the next check
    Call StartResponseCheckTimer
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
    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
        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





please edit the code the header for the list is also changing highlights based on the highlights of the first item on the list. can you also make the tracker to also monitor if theres a list that needs to be followed up to even for example the last follow up is 9/28 and theres no response so if I clicked on check responses and the tracker determenined that that list needs to be follow up can you make it automatically send the follow up? but for example its not 24 hrs yet from the last follow do not send another forllow up for that cause its not over 24 hrs yet. also can you fix the follow up to all button cause it seems to change shape or something whenever I delete a row.

can you also check everything in this like the code the layout the logics and setups, the design as well as the functionalities if you can think of anything better to add or to improve for this tracker to be more effecient, more reliable, more productive, more beautiful and easy to use please do so if you think I need to add more functionalities please do so do the changes update the entire code. send me the entire so I can copy and paste it to a new excel file. send the entire new updated code to me for all the modules that Ill need and also to codes to set up the tracker. send all the codes for each module.

if you are about to send the setup and utility module. ask me first because those modules are long. send me first the other modules send the entire updated code for each module to be updated. send me sheet1, thisworkbook and setupmodule first then ask me first to send you the rest of the codes