The following appears to work
Option Explicit
'Graham Mayor - https://www.gmayor.com - Last updated - 05 Nov 2020
Sub AddNote()
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.items
Dim olItem As Outlook.ContactItem
Dim i As Long
Dim strText As String
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
On Error Resume Next
strText = InputBox("Enter the text to Add to all contacts' notes." & vbCr & vbCr & _
"Text entered is case sensitive!")
If strText = "" Then GoTo lbl_Exit
On Error GoTo 0
Set olFolder = Session.PickFolder
Set olItems = olFolder.items
For i = olItems.Count To 1 Step -1
Set olItem = olItems(i)
With olItem
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.collapse 1
If .Body = "" Then
oRng.Text = strText
Else
oRng.Text = strText & vbCrLf
End If
oRng.Font.Bold = True 'set font to bold
oRng.Font.Color = RGB(255, 0, 0) ' set font colour to red
.Save
.Close 0
End With
DoEvents
Next i
lbl_Exit:
MsgBox strText & vbCr & "added to all items in" & vbCr & olFolder.Name, vbInformation
Set olFolder = Nothing
Set olItems = Nothing
Set olItem = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Sub RemoveNote()
Dim olFolder As Outlook.Folder
Dim olItems As Outlook.items
Dim olItem As Outlook.ContactItem
Dim i As Long
Dim strText As String
On Error Resume Next
strText = InputBox("Enter the text to Remove from all contacts' notes." & vbCr & vbCr & _
"Text entered is case sensitive!")
If strText = "" Then GoTo lbl_Exit
On Error GoTo 0
Set olFolder = Session.PickFolder
Set olItems = olFolder.items
For i = olFolder.items.Count To 1 Step -1
Set olItem = olItems(i)
With olItem
.Display
If InStr(1, .Body, vbCrLf) > 0 Then
.Body = Replace(.Body, strText & vbCrLf, "")
Else
.Body = Replace(.Body, strText, "")
End If
.Save
.Close 0
End With
DoEvents
Next i
lbl_Exit:
MsgBox strText & "removed from" & vbCr & olFolder.Name, vbInformation
Set olFolder = Nothing
Set olItems = Nothing
Set olItem = Nothing
Exit Sub
End Sub