Sending an Outlook calendar invite from within Access

[KFox via AccessMonster.com]

I have a table in Access that includes all the information I need to send
several calendar invites to internal employees at my company. Thanks to
Graham, I have gotten a few steps closer to getting this to work, but it's
still not there. At one point the code would add the calendar item directly
to my own calendar, but that's not what I need to have happen. I would like
the invite to go through Outlook so the recipient has to open the e-mail,
click on Accept and the invite will be added to their own calendar. Is this
even do-able?

Thanks in advance for your help!
Kellie

Here's my code thus far.

Option Compare Database

Private Sub AddAppt_Click()
On Error GoTo AddAppt_Err
On Error GoTo ProcErr
' Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Dim olkApp As Outlook.Application
Dim olkNsp As Outlook.NameSpace
Dim olkCalendar As Outlook.MAPIFolder
Dim olkUser As Outlook.Recipient
Dim olkAppt As Outlook.AppointmentItem
Dim sUser As String

On Error GoTo ProcErr
sUser = Me!MESSAGE_TO
Set olkApp = CreateObject("Outlook.Application")
Set olkNsp = olkApp.GetNamespace("MAPI")
Set olkUser = olkNsp.CreateRecipient(sUser)
If Not olkUser.Resolve Then
MsgBox "User '" & sUser & "' not found"
GoTo ProcEnd
End If

Set olkCalendar = olkNsp.GetSharedDefaultFolder(olkUser, olFolderCalendar)

If olkCalendar Is Nothing Then
MsgBox sUser & "'s calendar cannot be accessed"
GoTo ProcEnd
End If

Set olkAppt = olkCalendar.Items.Add(olAppointmentItem)
If olkAppt Is Nothing Then
MsgBox "Cannot create new appointment"
GoTo ProcEnd
End If

With olkAppt
.Start = Me!ApptDate & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!EVENT
'.Recipient = Me!MESSAGE_TO
If Not IsNull(Me!ApptNotes) Then .Body = Me!Company
If Not IsNull(Me!ApptLocation) Then .Location = _
Me!ApptLocation
If Me!ApptReminder Then
.ReminderMinutesBeforeStart = Me!ReminderMinutes
.ReminderSet = True
.Save
End If
End With
ProcEnd:
Set olkAppt = Nothing
Set olkCalendar = Nothing
Set olkUser = Nothing
Set olkNsp = Nothing
Set olkApp = Nothing

End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
Resume ProcEnd
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
ProcErr:
MsgBox Err.Description
Exit Sub
End Sub