Outlook Macro to revert safelink URLs while composing a reply.

readme.md

RevertSafeLinks Macro for Microsoft Outlook

This VBA macro processes email messages in Microsoft Outlook, replacing Microsoft Safe Links with their original URLs. It works for both plain text and HTML email formats.

Features

• Detects and processes Safe Links in email replies or inline responses.
• Extracts the original URL from the url parameter of Safe Links.
• Handles both plain text and HTML body formats.

How to Import and Use

1. Importing the Macro

1. Open the Outlook VBA Editor:

   • Press Alt + F11 to open the VBA editor.

2. Create a New Module:

   • In the VBA editor, click Insert → Module.

3. Paste the Macro Code:

   • Copy the macro code from this gist and paste it into the newly created module.

4. Save the Project:

   • Press Ctrl + S to save your changes.

2. Using the Macro

Method 1: Run Directly

1. Open the VBA editor (Alt + F11).
2. Select the RevertSafeLinks macro in the module.
3. Press F5 or click Run to execute.

Method 2: Add a Ribbon Button

1. Customize the Ribbon:
   • Go to File → Options → Customize Ribbon.
   • Add a new group to an existing tab (e.g., "Home (Mail)").
   • Select "Macros" from the dropdown and add the RevertSafeLinks macro to the new group.
2. Run the Macro:
   • Click the button from the ribbon to execute the macro.

Method 3: Assign a Keyboard Shortcut

1. Open the VBA editor (Alt + F11).
2. Go to Tools → Macros → Macros (or press Alt + F8).
3. Select RevertSafeLinks and click Options.
4. Assign a shortcut key (e.g., Ctrl + Shift + R) and click **OK`.
5. Use the assigned shortcut to run the macro.

3. Testing the Macro

1. Open an email with Safe Links in the body.
2. Trigger the macro using the method of your choice.
3. Verify that Safe Links are replaced with their original URLs.

Troubleshooting

• Macro Not Running:

  • Ensure macros are enabled in Outlook's Trust Center settings.
  • Verify that the macro is saved in the correct module.

• URL Replacement Issues:

  • Confirm the Safe Links domain matches safelinks.protection.outlook.com.
  • Check for malformed or unsupported Safe Link formats.

• Error Handling:

  • If the macro encounters an issue, it will display an error message. Verify the email content and try again.

License

This macro is provided under the MIT License. Use it at your own risk.

macro.vb

Sub RevertSafeLinks()
    Dim objMail As MailItem
    Dim objInspector As Inspector
    Dim objInlineResponse As Object

    ' Check for inline response first
    Set objInlineResponse = Application.ActiveExplorer.ActiveInlineResponse
    If Not objInlineResponse Is Nothing Then
        Set objMail = objInlineResponse
        ProcessMailItem objMail
    Else
        ' Check if there is an active inspector
        Set objInspector = Application.ActiveInspector
        If Not objInspector Is Nothing Then
            ' Check if the active item is a mail item
            Set objMail = objInspector.CurrentItem
            If objMail.Class = olMail Then
                ProcessMailItem objMail
            End If
        Else
            MsgBox "No active inspector or inline response window found.", vbExclamation
        End If
    End If
End Sub

Sub ProcessMailItem(objMail As MailItem)
    If objMail.BodyFormat = olFormatHTML Then
        ProcessHTMLBody objMail
    ElseIf objMail.BodyFormat = olFormatPlain Then
        ProcessPlainTextBody objMail
    End If
End Sub

Sub ProcessHTMLBody(objMail As MailItem)
    Dim objDoc As Object
    Dim objLink As Object
    Dim originalURL As String
    Dim safeLinkPrefix As String

    ' Define the Safe Links prefix
    safeLinkPrefix = "safelinks.protection.outlook.com"

    Set objDoc = objMail.GetInspector.WordEditor

    ' Loop through all hyperlinks in the mail item
    For Each objLink In objDoc.Hyperlinks
        If InStr(objLink.Address, safeLinkPrefix) > 0 Then
            ' Extract and decode the "url" parameter
            originalURL = ExtractURLParameter(objLink.Address, "url")
            If originalURL <> "" Then
                objLink.Address = originalURL
                objLink.TextToDisplay = originalURL
            End If
        End If
    Next objLink
End Sub

Sub ProcessPlainTextBody(objMail As MailItem)
    On Error GoTo ErrorHandler
    Dim safeLinkDomain As String
    Dim bodyText As String
    Dim linkStart As Long
    Dim linkURL As String
    Dim originalURL As String

    ' Define the base Safe Links domain
    safeLinkDomain = "safelinks.protection.outlook.com"

    bodyText = objMail.Body
    Do While InStr(bodyText, safeLinkDomain) > 0
        ' Backtrack to find the start of the Safe Link (typically starts with "http" or "https://")
        linkStart = FindURLStart(bodyText, InStr(bodyText, safeLinkDomain))

        ' Extract the full Safe Link URL
        linkURL = ExtractFullURL(bodyText, linkStart)

        ' Extract and decode the "url" parameter
        originalURL = ExtractURLParameter(linkURL, "url")
        If originalURL <> "" Then
            bodyText = Replace(bodyText, linkURL, originalURL)
        Else
            Exit Do ' Exit loop if no valid URL is found
        End If
    Loop
    objMail.Body = bodyText
    Exit Sub

ErrorHandler:
    MsgBox "An error occurred while processing plain text body: " & Err.Description, vbCritical
End Sub

Function FindURLStart(text As String, domainPosition As Long) As Long
    Dim i As Long
    ' Assume URLs start with "http" or "https://"
    For i = domainPosition To 1 Step -1
        If Mid(text, i, 4) = "http" Then
            FindURLStart = i
            Exit Function
        End If
    Next i
    ' Default to the domain position if no "http" is found
    FindURLStart = domainPosition
End Function

Function ExtractFullURL(text As String, startPos As Long) As String
    Dim i As Long
    Dim validChars As String
    Dim url As String

    ' Define valid URL characters
    validChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_.~/:?&=%#"

    ' Iterate through the text starting from the given position
    i = startPos
    Do While i <= Len(text)
        If InStr(1, validChars, Mid(text, i, 1)) > 0 Then
            url = url & Mid(text, i, 1)
        Else
            Exit Do
        End If
        i = i + 1
    Loop

    ExtractFullURL = url
End Function

Function ExtractURLParameter(fullURL As String, parameterName As String) As String
    Dim paramStart As Long
    Dim paramEnd As Long
    Dim encodedParam As String
    Dim decodedParam As String

    ' Locate the parameter in the URL
    paramStart = InStr(fullURL, parameterName & "=")
    If paramStart > 0 Then
        paramStart = paramStart + Len(parameterName) + 1
        paramEnd = InStr(paramStart, fullURL, "&")
        If paramEnd = 0 Then paramEnd = Len(fullURL) + 1

        ' Extract and decode the parameter value
        encodedParam = Mid(fullURL, paramStart, paramEnd - paramStart)
        decodedParam = DecodeURL(encodedParam)
        ExtractURLParameter = decodedParam
    Else
        ExtractURLParameter = ""
    End If
End Function

Function DecodeURL(safeLink As String) As String
    Dim decodedURL As String
    Dim i As Long
    Dim hexValue As String

    decodedURL = ""
    i = 1

    Do While i <= Len(safeLink)
        If Mid(safeLink, i, 1) = "%" Then
            hexValue = Mid(safeLink, i + 1, 2)
            decodedURL = decodedURL & ChrW("&H" & hexValue)
            i = i + 3
        Else
            decodedURL = decodedURL & Mid(safeLink, i, 1)
            i = i + 1
        End If
    Loop

    DecodeURL = decodedURL
End Function