I added the sample code provided by Sue Mosher, and it adds an
appointment to the shared calender, with a couple of problems.
1. The entry on the calendar is blank
2. The entry is only 15 minutes long no matter what the duration I set
on the access entry form.
3. The entry ignores the time entered on the access form and creates a
calendar entry for the current time.
below is the code how it is laid out in the access form.
Any help would be appreciated.
*********************begin code*************************
Private Sub cmdAddAppt_Click()
On Error GoTo Err_cmdAddAppt_Click
'Save record first to be sure required fields are filled.
DoCmd.GoToRecord , , acNewRec
'Exit the procedure if appointment has been added to Outlook.
If AddedToOutlook = True Then
MsgBox "This appointment is already added to MS Outlook"
Exit Sub
'Add a new Appointment.
Else
Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objDummy As Outlook.MailItem
Dim objRecip As Outlook.Recipient
Dim strMsg As String
Dim strName As String
On Error Resume Next
'## Change str to equal calendar you want to access##
strName = "(e-mail address removed)"
Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
Set objNS = objOutlook.GetNamespace("MAPI")
Set objDummy = objOutlook.CreateItem(olMailItem)
Set objRecip = objDummy.Recipients.Add(strName)
objRecip.Resolve
If objRecip.Resolved Then
On Error Resume Next
Set objFolder = _
objNS.GetSharedDefaultFolder(objRecip, _
olFolderCalendar)
If Not objFolder Is Nothing Then
Set objAppt = objFolder.Items.Add
If Not objAppt Is Nothing Then
With objAppt
'.Subject = "Test Appointment"
.Start = ApptDate & "" & ApptTime
.Duration = ApptLength
.Subject = Appt
.Save
.Close (olSave)
If Not IsNull(ApptNotes) Then .Body = ApptNotes
If Not IsNull(ApptLocation) Then .Location =
ApptLocation
If ApptReminder Then
.ReminderMinutesBeforeStart = ReminderMinutes
.ReminderSet = True
End If
End With
End If
End If
Else
MsgBox "Could Not Find " & Chr(34) & strName & Chr(34), , _
"User not Found"
End If
End If
'Release the Appointment object variable.
Set objOutlook = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Set objDummy = Nothing
Set objRecip = Nothing
Set objAppt = Nothing
'Set the AddedToOulook flag, save the record, display a message.
AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit_cmdAddAppt_Click:
Exit Sub
Err_cmdAddAppt_Click:
MsgBox Err.Description
Resume Exit_cmdAddAppt_Click
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
*** Sent via Developersdex
http://www.developersdex.com ***
Don't just participate in USENET...get rewarded for it!
