AdventGuru

Sub FixQBEmail()
   LeftJustifyInvoicePara
   ProofAndCleanEmail
End Sub
Sub ProofAndCleanEmail()
    Dim oInspector As Inspector
    Dim oItem As MailItem
    Dim oDoc As Object
    Dim sBody As String
    
    ' Get the currently open/active email being composed
    Set oInspector = Application.ActiveInspector
    
    If oInspector Is Nothing Then
        MsgBox "No email is currently open for editing.", vbExclamation
        Exit Sub
    End If
    
    If oInspector.CurrentItem.Class <> olMail Then
        MsgBox "The active item is not an email.", vbExclamation
        Exit Sub
    End If
    
    Set oItem = oInspector.CurrentItem
    
    ' --- Work on the BODY ---
    ' For HTML emails, we modify the plain text representation carefully.
    ' Using Word editor object for rich/HTML body editing is more robust.
    
    If oInspector.EditorType = olEditorWord Then
        ' Email is using Word as editor (default in modern Outlook)
        Set oDoc = oInspector.WordEditor
        Call CleanWordDocument(oDoc)
    Else
        ' Fallback: work on plain text body
        sBody = oItem.Body
        sBody = CleanDollarAmounts(sBody)
        oItem.Body = sBody
    End If
    
    'MsgBox "Email proofing complete!", vbInformation
End Sub
' -------------------------------------------------------
' Cleans a Word document (the email body in Word editor)
' -------------------------------------------------------
Sub CleanWordDocument(oDoc As Object)
    Dim oTable As Object
    Dim oCell As Object
    Dim oRange As Object
    Dim oFind As Object
    Dim i As Integer, j As Integer, k As Integer
    ' First try Find/Replace on the whole document content
    Call FindReplaceDollars(oDoc.Content)
    Call ReplaceText(oDoc.Content, "Your invoice is ready!", "Quartare")
    Call FixDateLineColor(oDoc.Content)
    Call RemoveDayOfWeek(oDoc.Content)
    Call UpdateToFirstOfNextMonth(oDoc.Content)
    'Call ColorDateGreen(oDoc.Content)
    Call FixHTMLBackgrounds
    ' Then explicitly loop through all tables and cells
    For i = 1 To oDoc.Tables.Count
        Set oTable = oDoc.Tables(i)
        For j = 1 To oTable.Rows.Count
            For k = 1 To oTable.Columns.Count
                On Error Resume Next  ' some cells may be merged
                Set oCell = oTable.Cell(j, k)
                If Err.Number = 0 Then
                    Call FindReplaceDollars(oCell.Range)
                End If
                On Error GoTo 0
            Next k
        Next j
    Next i
End Sub
Sub FindReplaceDollars(oRange As Object)
    Dim oRegex As Object
    Dim oMatches As Object
    Dim oMatch As Object
    Dim sFind As String
    Dim sReplace As String
    
    ' Use RegEx to identify what needs replacing
    Set oRegex = CreateObject("VBScript.RegExp")
    With oRegex
        .Global = True
        .Pattern = "\$([0-9,]+)\.00"
    End With
    
    Set oMatches = oRegex.Execute(oRange.Text)
    
    ' For each match, do a safe literal Word find/replace
    For Each oMatch In oMatches
        sFind = oMatch.Value                    ' e.g. $250.00
        sReplace = "$" & oMatch.SubMatches(0)   ' e.g. $250
        
        With oRange.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWildcards = False
            .Forward = True
            .Wrap = 1
            .Text = sFind
            .Replacement.Text = sReplace
            .Execute Replace:=2
        End With
    Next oMatch
End Sub
Sub ReplaceText(oRange As Object, sFind As String, sReplace As String)
    With oRange.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = False
        .Forward = True
        .Wrap = 1
        .Text = sFind
        .Replacement.Text = sReplace
        .Execute Replace:=2
    End With
End Sub
Sub FixDateLineColor(oRange As Object)
    Dim oPara As Object
    Dim oWord As Object
    
    For Each oPara In oRange.Paragraphs
        If InStr(oPara.Range.Text, "| Due ") > 0 Then
            ' Loop through each word/run in the paragraph and set to white
            For Each oWord In oPara.Range.Words
                oWord.Font.Color = RGB(50, 50, 50)  ' KS white?
            Next oWord
        End If
    Next oPara
End Sub
Sub FixHTMLBackgrounds()
    Dim oInspector As Inspector
    Dim oItem As MailItem
    Dim sHTML As String
    
    Set oInspector = Application.ActiveInspector
    Set oItem = oInspector.CurrentItem
    
    sHTML = oItem.htmlBody
    
    ' Fix background colors - replace with whatever colors you want
    'sHTML = Replace(sHTML, "bgcolor=""#ECEEF1""", "bgcolor=""#FFFFFF""")  ' outer body
    sHTML = Replace(sHTML, "background:#F4F4EF", "background:#7D99B6")    ' top section
    sHTML = Replace(sHTML, "background:#F4F5F8", "background:#F4F5F8")    ' footer section
    
    ' Fix the red date color while we're here
    'sHTML = Replace(sHTML, "color:#D52B1E", "color:#393A3D")              ' match surrounding text
    
    oItem.htmlBody = sHTML
    
    'MsgBox "Background colors updated.", vbInformation
End Sub
Sub RemoveDayOfWeek(oRange As Object)
    Dim sDays As String
    Dim oDays() As String
    Dim i As Integer
    
    sDays = "on Mon, |on Tue, |on Wed, |on Thu, |on Fri, |on Sat, |on Sun, "
    oDays = Split(sDays, "|")
    
    For i = 0 To UBound(oDays)
        Call ReplaceText(oRange, oDays(i), "")
    Next i
End Sub
Sub UpdateToFirstOfNextMonth(oRange As Object)
    Dim oRegex As Object
    Dim oMatches As Object
    Dim oMatch As Object
    Dim sOldDate As String
    Dim sNewDate As String
    Dim dDate As Date
    Dim dNewDate As Date
    
    ' Use RegEx to find MM/DD/YYYY pattern
    Set oRegex = CreateObject("VBScript.RegExp")
    With oRegex
        .Global = True
        .Pattern = "\d{2}/\d{2}/\d{4}"
    End With
    
    Set oMatches = oRegex.Execute(oRange.Text)
    
    If oMatches.Count = 0 Then
        MsgBox "No date found.", vbExclamation
        Exit Sub
    End If
    
    For Each oMatch In oMatches
        sOldDate = oMatch.Value
        
        ' Parse the found date
        dDate = CDate(sOldDate)
        
        ' Calculate first day of next month
        dNewDate = DateSerial(Year(dDate), Month(dDate) + 1, 1)
        
        ' Format back to MM/DD/YYYY
        sNewDate = Format(dNewDate, "MM/DD/YYYY")
        
        ' Use safe Word find/replace
        Call ReplaceText(oRange, sOldDate, sNewDate)
    Next oMatch
End Sub
Sub ColorDateGreen(oRange As Object)
    Dim oPara As Object
    Dim oRegex As Object
    Dim oMatches As Object
    Dim oMatch As Object
    Dim oFindRange As Object
    
    Set oRegex = CreateObject("VBScript.RegExp")
    With oRegex
        .Global = True
        .Pattern = "\d{2}/\d{2}/\d{4}"
    End With
    
    For Each oPara In oRange.Paragraphs
        Set oMatches = oRegex.Execute(oPara.Range.Text)
        
        For Each oMatch In oMatches
            ' Create a range for just the date
            Set oFindRange = oPara.Range.Duplicate
            oFindRange.Start = oPara.Range.Start + oMatch.FirstIndex
            oFindRange.End = oFindRange.Start + oMatch.Length
            
            ' #D86C00 converts to RGB(216, 108, 0)
            oFindRange.Font.Color = RGB(0, 137, 46)
        Next oMatch
    Next oPara
End Sub
Sub LeftJustifyInvoicePara()
    Dim oInspector As Inspector
    Dim oDoc As Object
    Dim oCell As Object
    Dim oPara As Object
    
    Set oInspector = Application.ActiveInspector
    Set oDoc = oInspector.WordEditor
    Set oCell = oDoc.Tables(1).Cell(1, 1)
    
    For Each oPara In oCell.Range.Paragraphs
        ' Find the paragraph that contains the invoice message
        If InStr(oPara.Range.Text, "Please remit payment") > 0 Then
            oPara.Alignment = 0
        End If
    Next oPara
End Sub

Sub FixQBEmail()

   LeftJustifyInvoicePara
   ProofAndCleanEmail

End Sub

Sub ProofAndCleanEmail()

    Dim oInspector As Inspector
    Dim oItem As MailItem
    Dim oDoc As Object
    Dim sBody As String
    
    ' Get the currently open/active email being composed
    Set oInspector = Application.ActiveInspector
    
    If oInspector Is Nothing Then
        MsgBox "No email is currently open for editing.", vbExclamation
        Exit Sub
    End If
    
    If oInspector.CurrentItem.Class <> olMail Then
        MsgBox "The active item is not an email.", vbExclamation
        Exit Sub
    End If
    
    Set oItem = oInspector.CurrentItem
    
    ' --- Work on the BODY ---
    ' For HTML emails, we modify the plain text representation carefully.
    ' Using Word editor object for rich/HTML body editing is more robust.
    
    If oInspector.EditorType = olEditorWord Then
        ' Email is using Word as editor (default in modern Outlook)
        Set oDoc = oInspector.WordEditor
        Call CleanWordDocument(oDoc)
    Else
        ' Fallback: work on plain text body
        sBody = oItem.Body
        sBody = CleanDollarAmounts(sBody)
        oItem.Body = sBody
    End If
    
    'MsgBox "Email proofing complete!", vbInformation
End Sub


' -------------------------------------------------------
' Cleans a Word document (the email body in Word editor)
' -------------------------------------------------------
Sub CleanWordDocument(oDoc As Object)
    Dim oTable As Object
    Dim oCell As Object
    Dim oRange As Object
    Dim oFind As Object
    Dim i As Integer, j As Integer, k As Integer

    ' First try Find/Replace on the whole document content

    Call FindReplaceDollars(oDoc.Content)
    Call ReplaceText(oDoc.Content, "Your invoice is ready!", "Quartare")
    Call FixDateLineColor(oDoc.Content)
    Call RemoveDayOfWeek(oDoc.Content)
    Call UpdateToFirstOfNextMonth(oDoc.Content)
    'Call ColorDateGreen(oDoc.Content)
    Call FixHTMLBackgrounds

    ' Then explicitly loop through all tables and cells
    For i = 1 To oDoc.Tables.Count
        Set oTable = oDoc.Tables(i)
        For j = 1 To oTable.Rows.Count
            For k = 1 To oTable.Columns.Count
                On Error Resume Next  ' some cells may be merged
                Set oCell = oTable.Cell(j, k)
                If Err.Number = 0 Then
                    Call FindReplaceDollars(oCell.Range)
                End If
                On Error GoTo 0
            Next k
        Next j
    Next i
End Sub

Sub FindReplaceDollars(oRange As Object)
    Dim oRegex As Object
    Dim oMatches As Object
    Dim oMatch As Object
    Dim sFind As String
    Dim sReplace As String
    
    ' Use RegEx to identify what needs replacing
    Set oRegex = CreateObject("VBScript.RegExp")
    With oRegex
        .Global = True
        .Pattern = "\$([0-9,]+)\.00"
    End With
    
    Set oMatches = oRegex.Execute(oRange.Text)
    
    ' For each match, do a safe literal Word find/replace
    For Each oMatch In oMatches
        sFind = oMatch.Value                    ' e.g. $250.00
        sReplace = "$" & oMatch.SubMatches(0)   ' e.g. $250
        
        With oRange.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .MatchWildcards = False
            .Forward = True
            .Wrap = 1
            .Text = sFind
            .Replacement.Text = sReplace
            .Execute Replace:=2
        End With
    Next oMatch
End Sub

Sub ReplaceText(oRange As Object, sFind As String, sReplace As String)
    With oRange.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = False
        .Forward = True
        .Wrap = 1
        .Text = sFind
        .Replacement.Text = sReplace
        .Execute Replace:=2
    End With
End Sub

Sub FixDateLineColor(oRange As Object)
    Dim oPara As Object
    Dim oWord As Object
    
    For Each oPara In oRange.Paragraphs
        If InStr(oPara.Range.Text, "| Due ") > 0 Then
            ' Loop through each word/run in the paragraph and set to white
            For Each oWord In oPara.Range.Words
                oWord.Font.Color = RGB(50, 50, 50)  ' KS white?
            Next oWord
        End If
    Next oPara
End Sub

Sub FixHTMLBackgrounds()
    Dim oInspector As Inspector
    Dim oItem As MailItem
    Dim sHTML As String
    
    Set oInspector = Application.ActiveInspector
    Set oItem = oInspector.CurrentItem
    
    sHTML = oItem.htmlBody
    
    ' Fix background colors - replace with whatever colors you want
    'sHTML = Replace(sHTML, "bgcolor=""#ECEEF1""", "bgcolor=""#FFFFFF""")  ' outer body
    sHTML = Replace(sHTML, "background:#F4F4EF", "background:#7D99B6")    ' top section
    sHTML = Replace(sHTML, "background:#F4F5F8", "background:#F4F5F8")    ' footer section
    
    ' Fix the red date color while we're here
    'sHTML = Replace(sHTML, "color:#D52B1E", "color:#393A3D")              ' match surrounding text
    
    oItem.htmlBody = sHTML
    
    'MsgBox "Background colors updated.", vbInformation
End Sub

Sub RemoveDayOfWeek(oRange As Object)
    Dim sDays As String
    Dim oDays() As String
    Dim i As Integer
    
    sDays = "on Mon, |on Tue, |on Wed, |on Thu, |on Fri, |on Sat, |on Sun, "
    oDays = Split(sDays, "|")
    
    For i = 0 To UBound(oDays)
        Call ReplaceText(oRange, oDays(i), "")
    Next i
End Sub

Sub UpdateToFirstOfNextMonth(oRange As Object)
    Dim oRegex As Object
    Dim oMatches As Object
    Dim oMatch As Object
    Dim sOldDate As String
    Dim sNewDate As String
    Dim dDate As Date
    Dim dNewDate As Date
    
    ' Use RegEx to find MM/DD/YYYY pattern
    Set oRegex = CreateObject("VBScript.RegExp")
    With oRegex
        .Global = True
        .Pattern = "\d{2}/\d{2}/\d{4}"
    End With
    
    Set oMatches = oRegex.Execute(oRange.Text)
    
    If oMatches.Count = 0 Then
        MsgBox "No date found.", vbExclamation
        Exit Sub
    End If
    
    For Each oMatch In oMatches
        sOldDate = oMatch.Value
        
        ' Parse the found date
        dDate = CDate(sOldDate)
        
        ' Calculate first day of next month
        dNewDate = DateSerial(Year(dDate), Month(dDate) + 1, 1)
        
        ' Format back to MM/DD/YYYY
        sNewDate = Format(dNewDate, "MM/DD/YYYY")
        
        ' Use safe Word find/replace
        Call ReplaceText(oRange, sOldDate, sNewDate)
    Next oMatch
End Sub

Sub ColorDateGreen(oRange As Object)
    Dim oPara As Object
    Dim oRegex As Object
    Dim oMatches As Object
    Dim oMatch As Object
    Dim oFindRange As Object
    
    Set oRegex = CreateObject("VBScript.RegExp")
    With oRegex
        .Global = True
        .Pattern = "\d{2}/\d{2}/\d{4}"
    End With
    
    For Each oPara In oRange.Paragraphs
        Set oMatches = oRegex.Execute(oPara.Range.Text)
        
        For Each oMatch In oMatches
            ' Create a range for just the date
            Set oFindRange = oPara.Range.Duplicate
            oFindRange.Start = oPara.Range.Start + oMatch.FirstIndex
            oFindRange.End = oFindRange.Start + oMatch.Length
            
            ' #D86C00 converts to RGB(216, 108, 0)
            oFindRange.Font.Color = RGB(0, 137, 46)
        Next oMatch
    Next oPara
End Sub

Sub LeftJustifyInvoicePara()
    Dim oInspector As Inspector
    Dim oDoc As Object
    Dim oCell As Object
    Dim oPara As Object
    
    Set oInspector = Application.ActiveInspector
    Set oDoc = oInspector.WordEditor
    Set oCell = oDoc.Tables(1).Cell(1, 1)
    
    For Each oPara In oCell.Range.Paragraphs
        ' Find the paragraph that contains the invoice message
        If InStr(oPara.Range.Text, "Please remit payment") > 0 Then
            oPara.Alignment = 0
        End If
    Next oPara
End Sub