Copying the "Link to Record" from an Appointment to a Task

[Rekab13]

With assistance from the people at "OutlookCode.com" specifically Sue Mosher,
I have pieced together code (see below) to create follow-up Tasks for an
Appointment. I have not been able to copy the BCM "Link to Record" from the
original Appointment to the new Tasks. Any suggestions are greatly
appreciated.


===== CODE ====

Sub Add_Follow()
Dim objApp As Outlook.Application
Dim objItem As Object
Dim objTask1 As Outlook.TaskItem
Dim objTask4 As Outlook.TaskItem
Dim objTask6 As Outlook.TaskItem


On Error Resume Next
Set objApp = CreateObject("Outlook.Application")
Set objItem = objApp.ActiveInspector.CurrentItem
If objItem.Class = olAppointment Then
Set objTask1 = objApp.CreateItem(olTaskItem)
Set objTask4 = objApp.CreateItem(olTaskItem)
Set objTask6 = objApp.CreateItem(olTaskItem)

With objTask1
..StartDate = objItem.End + 7
..Subject = objItem.Subject & " | 1 week follow-up"
..ReminderSet = True
..ReminderTime = objItem.End + 6
End With
Call CopyFullBody(objItem, objTask1)


With objTask4
..StartDate = objItem.End + 28
..Subject = objItem.Subject & " | 4 week follow-up"
..ReminderSet = True
..ReminderTime = objItem.End + 27
End With
Call CopyFullBody(objItem, objTask4)

With objTask6
..StartDate = objItem.End + 182
..Subject = objItem.Subject & " | 6 month follow-up"
' .Body = objItem.Body
..ReminderSet = True
..RemindeTime = .StartDate - 2
End With
Call CopyFullBody(objItem, objTask6)

objTask1.Display
objTask4.Display
objTask6.Display

End If

Set objApp = Nothing
Set objItem = Nothing
Set objTask1 = Nothing
Set objTask4 = Nothing
Set objTask6 = Nothing

End Sub

Sub CopyFullBody(sourceItem As Object, targetItem As Object)
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objDoc2 As Word.Document
Dim objSel2 As Word.Selection
On Error Resume Next
' get a Word.Selection from the source item
Set objDoc = sourceItem.GetInspector.WordEditor
If Not objDoc Is Nothing Then
Set objSel = objDoc.Windows(1).Selection
objSel.WholeStory
objSel.Copy
Set objDoc2 = targetItem.GetInspector.WordEditor
If Not objDoc2 Is Nothing Then
Set objSel2 = objDoc2.Windows(1).Selection
objSel2.PasteAndFormat wdPasteDefault
Else
MsgBox "Could not get Word.Document for " & _
targetItem.Subject
End If
Else
MsgBox "Could not get Word.Document for " & _
sourceItem.Subject
End If
Set objDoc = Nothing
Set objSel = Nothing
Set objDoc2 = Nothing
Set objSel2 = Nothing
End Sub

===== END =====