K
kbrad
I am trying to add a Contact link to an appointment item using the Links collection as previously advised but am lost. My code (see below) adds an appointment item from an Access input form - no problem but I want to add the Contact link in addition to the basic appointment fields. Can anyone help with the code to do this
This code as it stands works so I have included this so you can see what I'm trying to do - I've removed all my failed attempts at including a Contact
Private Sub AddApp_Click(
On Error GoTo AddApp_Er
DoCmd.RunCommand acCmdSaveRecor
' Exit the procedure if appointment has been added to Outlook
If Me!AddedToOutlook = True The
MsgBox "This appointment already added to Microsoft Outlook
Exit Su
' Add a new appointment
Els
Dim outobj As Outlook.Applicatio
Dim outappt As Outlook.AppointmentIte
Set outobj = CreateObject("outlook.application"
Set outappt = outobj.CreateItem(olAppointmentItem
With outapp
.Start = Me!ApptDate & " " & Me!ApptTim
.Duration = Me!ApptLengt
.Subject = Me!App
If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNote
If Not IsNull(Me!ApptLocation) Then .Location =
Me!ApptLocatio
If Me!ApptReminder The
.ReminderMinutesBeforeStart = Me!ReminderMinute
.ReminderSet = Tru
End I
.Sav
End Wit
End I
' Release the Outlook object variable
Set outobj = Nothin
' Set the AddedToOutlook flag, save the record, display a message
Me!AddedToOutlook = Tru
DoCmd.RunCommand acCmdSaveRecor
MsgBox "Appointment Added!
Exit Su
AddApp_Err
MsgBox "Error " & Err.Number & vbCrLf & Err.Descriptio
Exit Su
End Sub
This code as it stands works so I have included this so you can see what I'm trying to do - I've removed all my failed attempts at including a Contact
Private Sub AddApp_Click(
On Error GoTo AddApp_Er
DoCmd.RunCommand acCmdSaveRecor
' Exit the procedure if appointment has been added to Outlook
If Me!AddedToOutlook = True The
MsgBox "This appointment already added to Microsoft Outlook
Exit Su
' Add a new appointment
Els
Dim outobj As Outlook.Applicatio
Dim outappt As Outlook.AppointmentIte
Set outobj = CreateObject("outlook.application"
Set outappt = outobj.CreateItem(olAppointmentItem
With outapp
.Start = Me!ApptDate & " " & Me!ApptTim
.Duration = Me!ApptLengt
.Subject = Me!App
If Not IsNull(Me!ApptNotes) Then .Body = Me!ApptNote
If Not IsNull(Me!ApptLocation) Then .Location =
Me!ApptLocatio
If Me!ApptReminder The
.ReminderMinutesBeforeStart = Me!ReminderMinute
.ReminderSet = Tru
End I
.Sav
End Wit
End I
' Release the Outlook object variable
Set outobj = Nothin
' Set the AddedToOutlook flag, save the record, display a message
Me!AddedToOutlook = Tru
DoCmd.RunCommand acCmdSaveRecor
MsgBox "Appointment Added!
Exit Su
AddApp_Err
MsgBox "Error " & Err.Number & vbCrLf & Err.Descriptio
Exit Su
End Sub