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

[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 (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