VBA: How do I add a shortcut to an email into the body of an appointment

Question

Dear all,
I want to write a macro for outlook that lets me do the following:
1. Move a selected email to a specific folder (with selection box)
2. create an appointment in a non default calendar with the same subject as the email
3. Put a link into the appointment body that links to the email (similar to the option that Outlook gives you when you drag an email onto the calender: "Copy Here as Appointment with Shortcut")
Unfortunately step 3 (creating the link to the email) can not be recreated unsing QuickSteps. Therefore I have to solve this with VBA.
Here is the code I came up with so far:
Sub Mail2Appt()
' Moves each of the selected items on the screen to a selected folder.
Dim olApp As New Outlook.Application
Dim olExp As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim olNameSpace As Outlook.NameSpace
Dim olDestFolder As Outlook.Folder
Dim intItem As Integer
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
Set olNameSpace = olApp.GetNamespace("MAPI")
'1. Handle the movement of the selected emails
'Display form to pick destination Folder
Set olDestFolder = olNameSpace.PickFolder
'To do: folder type validation
If TypeName(olDestFolder) <> "Nothing" Then
'Debug.Print vbCr & " olDestFolder: " & olDestFolder
Else
'Debug.Print vbCr & "Cancel"
Exit Sub
End If
'Move selection to new folder
For intItem = 1 To olSel.Count
olSel.Item(intItem).Move olDestFolder
Next intItem
'2. Create appointment in To-Do-Calendar
Dim myCalItem As Outlook.AppointmentItem
Dim myToDoCalendar As Outlook.Folder
'get non-default calender
Set myToDoCalendar = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("Aufgaben-Kalender")
For intItem = 1 To olSel.Count
Set myCalItem = myToDoCalendar.Items.Add(olAppointmentItem)
myCalItem.Subject = olSel.Item(intItem).Subject
myCalItem.Location = "Office"
myCalItem.Duration = 30
'3. Place link to email in appointment body
myCalItem.Body = "Hello World" 'Link to Email must go here
myCalItem.Display
Next intItem
End Sub
It would be great if somebody could push me in the right direction.
Cheers,
Sascha

Answer 1

To Edit the body you need to invoke the WordEditor Inspector. You can then program the body as if you were programming in Word itself e.g.
Add these declarations
Dim olInsp As Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strLink As String
Then substitute your own link
With myCalItem
.Subject = olSel.Item(intItem).Subject
.Location = "Office"
.Duration = 30
'3. Place link to email in appointment body
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
.Display
oRng.Text = "Hello World " 'Link to Email must go here
oRng.collapse 0
strLink = "https://www.fedex.com/fedextrack/?tracknumbers="
wdDoc.Hyperlinks.Add Anchor:=oRng, _
Address:=strLink, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:="Fedex Tracking Site"
End With
Graham Mayor - Word MVP
www.gmayor.com