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

[Witzker]

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

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

[gmayor]

The following will do that

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

[Witzker]

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

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 ObjectDim 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

[gmayor]

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.

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

[Witzker]

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?

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

[Witzker]

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

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