Created
February 16, 2024 15:05
-
-
Save oaustegard/3f68203a1c9822e0d6714e1ce9e6412b to your computer and use it in GitHub Desktop.
Outlook Macro to Reverse Email Threads
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
' Function to split the email body into individual messages | |
Function SplitEmailIntoMessages(strBody As String) As Variant | |
Dim regEx As New RegExp | |
Dim matches As MatchCollection | |
Dim arrMessages() As String | |
Dim i As Long | |
With regEx | |
.Pattern = "^From:" | |
.Global = True | |
.IgnoreCase = True | |
.MultiLine = True | |
Set matches = .Execute(strBody) | |
End With | |
If matches.Count > 0 Then | |
ReDim arrMessages(matches.Count) | |
arrMessages(0) = Left(strBody, matches(0).FirstIndex) | |
For i = 0 To matches.Count - 1 | |
If i < matches.Count - 1 Then | |
arrMessages(i + 1) = Mid(strBody, matches(i).FirstIndex + 1, matches(i + 1).FirstIndex - matches(i).FirstIndex) | |
Else | |
arrMessages(i + 1) = Mid(strBody, matches(i).FirstIndex + 1) | |
End If | |
Next i | |
Else | |
ReDim arrMessages(0) | |
arrMessages(0) = strBody | |
End If | |
SplitEmailIntoMessages = arrMessages | |
End Function | |
' Function to clean a single message | |
Function CleanMessage(message As String) As String | |
message = RemoveSubjectLine(message) | |
message = RemoveExtraBlankLines(message) | |
message = RemoveDisclosureFromMessage(message) | |
CleanMessage = message | |
End Function | |
Function RemoveSubjectLine(strBody As String) As String | |
Dim regEx As Object | |
Set regEx = CreateObject("VBScript.RegExp") | |
With regEx | |
.Global = True | |
.MultiLine = True | |
.IgnoreCase = True | |
.Pattern = "Subject:.*[\r\n]+" | |
RemoveSubjectLine = .Replace(strBody, "") | |
End With | |
End Function | |
Function RemoveExtraBlankLines(strBody As String) As String | |
Dim regEx As Object | |
Set regEx = CreateObject("VBScript.RegExp") | |
With regEx | |
.Global = True | |
.MultiLine = True | |
' Address general case of multiple consecutive newlines | |
.Pattern = "(\r\n){2,}" | |
strBody = .Replace(strBody, vbCrLf) | |
' Consider different newline conventions | |
.Pattern = "(\n){2,}" | |
strBody = .Replace(strBody, vbLf) | |
End With | |
RemoveExtraBlankLines = strBody | |
End Function | |
Function TrimTrailingSpacesFromLines(strBody As String) As String | |
Dim lines As Variant | |
Dim i As Long | |
lines = Split(strBody, vbCrLf) ' Split the text into lines | |
' Trim trailing spaces from each line | |
For i = LBound(lines) To UBound(lines) | |
lines(i) = RTrim(lines(i)) | |
Next i | |
' Reassemble the text | |
TrimTrailingSpacesFromLines = Join(lines, vbCrLf) | |
End Function | |
Function RemoveDisclosureFromMessage(message As String) As String | |
Dim pos As Long | |
pos = InStr(message, String(50, "=")) ' Find the position of 50 consecutive "=" | |
If pos > 0 Then | |
RemoveDisclosureFromMessage = Left(message, pos - 1) ' Remove everything from "=" onwards | |
Else | |
RemoveDisclosureFromMessage = message ' No disclosure found, return original message | |
End If | |
End Function | |
' Function to reverse the array of messages | |
Function ReverseMessages(arrMessages As Variant) As Variant | |
Dim i As Long | |
Dim temp As String | |
For i = 0 To UBound(arrMessages) \ 2 | |
temp = arrMessages(i) | |
arrMessages(i) = arrMessages(UBound(arrMessages) - i) | |
arrMessages(UBound(arrMessages) - i) = temp | |
Next i | |
ReverseMessages = arrMessages | |
End Function | |
' Function to compile messages back into a single string | |
Function CompileMessages(arrMessages As Variant, separator As String) As String | |
Dim i As Long | |
Dim compiledBody As String | |
Dim msg As String | |
For i = LBound(arrMessages) To UBound(arrMessages) | |
msg = arrMessages(i) | |
compiledBody = compiledBody & CleanMessage(msg) | |
' Add the separator only if it's not the last message in the array | |
If i <> UBound(arrMessages) Then | |
compiledBody = compiledBody & separator | |
End If | |
Next i | |
CompileMessages = compiledBody | |
End Function | |
Sub RewriteChronologicallyWithForward() | |
Dim olItem As mailItem | |
Dim fwdItem As mailItem ' The forwarded email item | |
Dim arrMessages As Variant | |
Dim compiledBody As String | |
Dim separator As String | |
separator = vbCrLf & "#######################################################################" & vbCrLf & vbCrLf | |
' Check if there is an open Inspector window (an open email) | |
If Not Application.ActiveInspector Is Nothing Then | |
Set olItem = Application.ActiveInspector.CurrentItem | |
' Otherwise, use the selected item in the Explorer window | |
ElseIf Not Application.ActiveExplorer.Selection Is Nothing Then | |
Set olItem = Application.ActiveExplorer.Selection.Item(1) | |
Else | |
MsgBox "Please select or open an email to use this macro.", vbExclamation | |
Exit Sub | |
End If | |
' Ensure the object is a MailItem | |
If TypeName(olItem) <> "MailItem" Then | |
MsgBox "This macro can only be used with emails.", vbExclamation | |
Exit Sub | |
End If | |
' Initiate the forward action | |
Set fwdItem = olItem.Forward | |
' Modify the subject of fwdItem to indicate the reversal action | |
' This adds "Reversed Thread:" prefix to the original subject | |
fwdItem.Subject = "Reversed Thread: " & olItem.Subject | |
' The rest of your logic for handling the email content | |
arrMessages = SplitEmailIntoMessages(fwdItem.Body) | |
arrMessages = ReverseMessages(arrMessages) | |
' Compile the messages back into a single string | |
compiledBody = CompileMessages(arrMessages, separator) | |
' Update the fwdItem's body with the reversed thread | |
fwdItem.Body = compiledBody | |
' Display the modified forward email for review or sending | |
fwdItem.Display | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
You're all familiar with the situation: you get added to a lengthy email thread and to catch up you now have to ratchet upwards through the email: scroll to the bottom, start scrolling back up to find the start of the last message, read to the end, scroll back up to find the start of the prior message, read to the end, and so on and so on. Rub your neck and curse the sender when through.
Wouldn't it be nice if Outlook had a function to reverse the thread so you could read it in chronological order?
It took longer than anticipated, but I finally came up with a workable solution/hack:
A custom Ribbon button triggering a Macro that
Caveat
The current code uses the
MailItem.Body
which is the plain text version of the email. It should be fully feasible to instead use theHtmlBody
and preserve the formatting, but for now this was stamped Good Enough and I moved on.