Help with macro to insert date at the end of oulook contact body

I have found a macro that Inserts date at the top of the body

Code:

---

Insert date at the top of the body

Public Sub AddNoteTop()
  Dim DefaultMsg$
 
  DefaultMsg = ""
 
  AddNote_Ex Application.ActiveInspector, DefaultMsg
End Sub
Private Sub AddNote_Ex(Inspector As Outlook.Inspector, Optional Msg As String)
  Dim WdSel As Word.Selection
  Dim p&
Msg = Format(Date, "mm/dd/yyyy", vbUseSystemDayOfWeek, vbUseSystem) & _
    ": " & Msg
  Msg = vbCrLf & "---" & vbCrLf & Msg
  Set WdSel = GetCurrentWordSelection(Inspector)
  p = Len(Msg) - 2
  WdSel.Start = 0
  WdSel.End = 0
  WdSel.InsertBefore Msg
  WdSel.Start = WdSel.Start + p
  WdSel.End = WdSel.Start
End Sub
Private Function GetCurrentWordSelection(OpenInspector As Outlook.Inspector) As Word.Selection
  Dim Doc As Word.Document
  Dim Wd As Word.Application
 
  Set Doc = OpenInspector.WordEditor
  Set Wd = Doc.Application
  Set GetCurrentWordSelection = Wd.Selection
End Function

---

Can you Pls?
Be so kind and tell me how to insert the text at the end of the body of a Contact Item in Outlook 2019
And if possible in green
THX in advance

The following will do that

Code:

---

Public Sub AddDateEnd()
'Graham Mayor - https://www.gmayor.com - Last updated - 09 Nov 2020
Dim olItem As ContactItem
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olItem = ActiveInspector.currentItem
        Case olExplorer
            Set olItem = Application.ActiveExplorer.Selection.Item(1)
    End Select
    With olItem
        .Display
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.collapse 0 'set to1 to put the date at the start of the body
        oRng.Text = Format(Date, "mm/dd/yyyy")
        oRng.Font.Color = RGB(0, 128, 0) 'green
        .Save
        .Close 0
    End With
lbl_Exit:
    Set olItem = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

THX great

Can you pls help me on to

oRng.Text = Format(Date, "mm/dd/yyyy") & " Call:" & vbCrLf ' could you pls be so kind and ad also actual time HH.MM

.Save ' Please place the cursor at the end of what has been inserted to be able to start writing

.Close 0 'Do not Close for further inserting text there

Code:

---

Public Sub AddDateEnd()
'Graham Mayor - https://www.gmayor.com - Last updated - 09 Nov 2020
Dim olItem As ContactItem
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olItem = ActiveInspector.CurrentItem
        Case olExplorer
            Set olItem = Application.ActiveExplorer.Selection.Item(1)
    End Select
    With olItem
        .Display
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.Collapse 0 'set to1 to put the date at the start of the body
        oRng.Text = Format(Date, "mm/dd/yyyy") & " Call:" & vbCrLf 'Pls ad also actual time HH.MM
        oRng.Font.Color = RGB(0, 128, 0) 'green
        .Save
        ' place the cursor at the end of what has been inserted to be able to start writing
        '.Close 0 'Do not Close for further inserting text there
    End With
lbl_Exit:
    Set olItem = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

Hope for further help
THX

The following will do what you ask, but it is not clear where you want the extra text or what colour you want for the rest but you should be able to work out how to set the ranges from that shown below.

Code:

---

Public Sub AddDateEnd()
'Graham Mayor - https://www.gmayor.com - Last updated - 09 Nov 2020
Dim olItem As ContactItem
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olItem = ActiveInspector.currentItem
        Case olExplorer
            Set olItem = Application.ActiveExplorer.Selection.Item(1)
    End Select
    With olItem
        .Display
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        If Len(oRng) > 2 Then
            oRng.collapse 0
            oRng.Text = vbCrLf
        End If
        oRng.collapse 0
        oRng.Text = Format(Date, "mm/dd/yyyy") & " Call:" & vbCrLf & Format(Time, "HH.MM ")
        oRng.Paragraphs(1).Range.Font.Color = RGB(0, 128, 0)    'green
        ' place the cursor at the end of what has been inserted to be able to start writing
        oRng.collapse 0
        oRng.Select
        .Save
        '.Close 0 'Do not Close for further inserting text there
    End With
lbl_Exit:
    Set olItem = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

Great THX

What I found is that the cursor is in the field beyond the insert but The focus is still in another field. Where it was when running the macro!
So when I want start to write the result of the call - The text is not in the body! It goes to the field where the cursor was!

Can You Pls help again?

Code:

---

Public Sub AddDateEnd()'Graham Mayor - https://www.gmayor.com - Last updated - 09 Nov 2020
Dim olItem As ContactItem
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
    On Error Resume Next
    Select Case Outlook.Application.ActiveWindow.Class
        Case olInspector
            Set olItem = ActiveInspector.CurrentItem
        Case olExplorer
            Set olItem = Application.ActiveExplorer.Selection.Item(1)
    End Select
    With olItem
        .Display
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        If Len(oRng) > 2 Then
            oRng.Collapse 0
            oRng.Text = vbCrLf
        End If
        oRng.Collapse 0
        oRng.Text = vbCrLf & Format(Date, "mm/dd/yyyy") & "-" & Format(Time, "HH.MM ") & " Call: "
        oRng.Paragraphs(2).Range.Font.Color = RGB(0, 128, 0)    'green
        ' place the cursor at the end of what has been inserted to be able to start writing
        oRng.Collapse 0
        oRng.Select
        ' set focus un cursr position to be able to enter text there after executing the macro
        '.Save 'saving manualy With Save& close
        '.Close 0 'Do not Close for further inserting text there
    End With
lbl_Exit:
    Set olItem = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

Maybe it is not clear?

This macro insertsDATE - Time & MESSAGE: at the end of an Outlook contact form.
This is working fineso far. But after handling this, I have no "real" focus, which meanswhen I press any key, nothing is typed to the body. I can see the cursor but itis not blinking. Hope you understand what I mean.
The cursor is stillin this field or position where it was before starting the macro
How to set focusthere to be able to start writing

Code:

---

Public Sub AddDateEnd()'Graham Mayor - https://www.gmayor.com - Last updated - 09 Nov 2020
Dim olItem As ContactItem
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
On Error Resume Next
Select Case Outlook.Application.ActiveWindow.Class
Case olInspector
Set olItem = ActiveInspector.CurrentItem
Case olExplorer
Set olItem = Application.ActiveExplorer.Selection.Item(1)
End Select
With olItem
.Display
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
If Len(oRng) > 2 Then
oRng.Collapse 0
oRng.Text = vbCrLf
End If
oRng.Collapse 0
oRng.Text = vbCrLf & Format(Date, "mm/dd/yyyy") & "-" & Format(Time, "HH.MM ") & " Call: "
oRng.Paragraphs(2).Range.Font.Color = RGB(0, 128, 0) 'green
' place the cursor at the end of what has been inserted to be able to start writing
oRng.Collapse 0
oRng.Select
' set focus un cursr position to be able to enter text there after executing the macro
'.Save 'saving manualy With Save& close
'.Close 0 'Do not Close for further inserting text there
End With
lbl_Exit:
Set olItem = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub

---