Skip to content

Instantly share code, notes, and snippets.

@oaustegard

oaustegard/Rethread.vba

Created February 16, 2024 15:05
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save oaustegard/3f68203a1c9822e0d6714e1ce9e6412b to your computer and use it in GitHub Desktop.
Save oaustegard/3f68203a1c9822e0d6714e1ce9e6412b to your computer and use it in GitHub Desktop.
Download ZIP
Outlook Macro to Reverse Email Threads
Raw
Rethread.vba
' 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
@oaustegard
Copy link
Author

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

  1. creates a Forward of the current email
  2. parses the text into a list of individual messages
  3. iterates through the body of that forward looking for "From:" clues that indicate a different message
  4. does some cleanup of each message
  5. reverses the message list
  6. combines it back into a single string
  7. shows you the rethreaded email in a new window for your chronological reading "pleasure"

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 the HtmlBody and preserve the formatting, but for now this was stamped Good Enough and I moved on.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment