Script to remove overly-long external email notification

[EricJaakkola]

I'm using this at the moment, and it works but it also strips all in-line images from the body which is not ok.
Is there a way to remove only this text at the top of the email but not break the formatting or contents of the rest of the email?



Sub ShrinkAlert(MyMail As MailItem)
Dim body As String, re As Object, match As Variant


body = MyMail.body
body = Replace(body, "CAUTION! This is an EXTERNAL email originated from outside the organization. Do not click links or open attachments unless you recognize the sender and know the content is safe. ", "EXTERNAL:", 1, -1, vbTextCompare)


MyMail.body = body
MyMail.Save
End Sub



My source info:
Replace Text: https://superuser.com/questions/464000/how-to-replace-text-in-the-body-of-an-incoming-message-with-a-hyperlink-in-outlo
Enable Run Script rule: https://www.slipstick.com/outlook/rules/outlook-run-a-script-rules/
Allow Macros: https://www.techrepublic.com/article/how-to-use-this-vba-procedure-to-reset-outlook-view-settings-each-time-you-launch/#:~:text=Click%20the%20File%20tab%2C%20choose,All%20Macros%20(Figure%20A).

[gmayor]

I think the following should work for you


Sub ShrinkAlert(MyMail As MailItem)
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Const sText As String = "CAUTION! This is an EXTERNAL email originated from outside the organization. Do not click links or open attachments unless you recognize the sender and know the content is safe."
With MyMail
.Display
Set olInsp = .GetInspector
If Not (MyMail.Recipients Is Nothing) And Not (MyMail.sender Is Nothing) Then
'open in "Edit" mode
olInsp.CommandBars.ExecuteMso ("EditMessage")
End If
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(findText:=sText)
oRng.Text = "EXTERNAL: "
oRng.Font.Color = &HFF&
oRng.collapse 0
Exit Do
Loop
End With
.Save
.Close 1
End With
End Sub

[EricJaakkola]

It opened the first email in a new window and returned a Rule in Error warning "An unexpected error has occurred"

[gmayor]

The code is intended to run from a rule when the messages arrive. I have added a trap for appointment items and set the resulting message as unread, but otherwise it should work and certainly does here


Sub ShrinkAlert(MyMail As MailItem)
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Const sText As String = "CAUTION! This is an EXTERNAL email originated from outside the organization. Do not click links or open attachments unless you recognize the sender and know the content is safe."
If TypeName(MyMail) = "MailItem" Then
With MyMail
.Display
Set olInsp = .GetInspector
If Not (MyMail.Recipients Is Nothing) And Not (MyMail.sender Is Nothing) Then
'open in "Edit" mode
olInsp.CommandBars.ExecuteMso ("EditMessage")
End If
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
With oRng.Find
Do While .Execute(findText:=sText)
oRng.Text = "EXTERNAL: "
oRng.Font.Color = &HFF&
oRng.collapse 0
Exit Do
Loop
End With
.Save
.Close 1
.UnRead = True
End With
End If
lbl_Exit:
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub