[AccessD] Access to Outlook Calendar

Hi rocky
 
Is this any use?
 
johnc
'---------------------------------------------------------------------------
------------
'  Procedure : btnAddApptToOutlook_Click
' DateTime  : 8/4/2008
'  Author    : Patrick Wood  _http://gainingaccess.net_ 
(http://gainingaccess.net) 
'  Purpose   : Add a Custom Access Appointment Record to the Outlook  
Calendar
' Arguments :  None
'           : You are  welcome to use this code if you give  
'           : us credit by  leaving this header  intact.
'---------------------------------------------------------------------------
------------
'
Private  Sub btnAddApptToOutlook_Click()
On Error GoTo  Err_btnAddApptToOutlook_Click
 
    ' Save the Current Record
If  Me.Dirty Then
Me.Dirty =  False
End If
 
    ' Exit the procedure if appointment has been added to  Outlook.
If Me.chkAddedToOutlook = True  Then
MsgBox "This appointment has  already added to Microsoft Outlook.",  
vbCritical
Exit  Sub

Else
' Add a new  appointment.
' Use late binding to  avoid the "Reference" issue
Dim  olApp As Object      'Outlook.Application
Dim olAppt As  Object    'olAppointmentItem
 
        ' This is how we would do it if  we were using "early binding":
'         Dim outobj As Outlook.Application
'         Dim outappt As  Outlook.AppointmentItem
'        Set  outobj =  CreateObject("Outlook.Application")
'         Set outappt = outobj.CreateItem(olAppointmentItem)
 
        If  isAppThere("Outlook.Application") = False  Then
'  Outlook is not open, create a new  instance
Set olApp =  CreateObject("Outlook.Application")
Else
'  Outlook is already open--use this  method
Set  olApp = GetObject(,  "Outlook.Application")
End  If

' Create the New Appointment  Item
Set olAppt =  olApp.CreateItem(1) ' olAppointmentItem =  1

' Add the Form data to the  Appointment Properties
With  olAppt
' If  There is no Start Date or Time  on
' the Form  use Nz to avoid an error

' Set the Start  Property Value
.Start = Nz(Me.txtStartDate, "") & " " & Nz(Me.txtStartTime,  "")

' Set the  End Property  Value
.End  = Nz(Me.txtEndDate, "") & " " & Nz(Me.txtEndTime,  "")

.Duration  = Nz(Me.txtApptLength,  0)

'  vbNullString uses a little less memory than  ""
.Subject = Nz(Me.cboApptDescription,  vbNullString)

.Body =  Nz(Me.txtApptNotes,  vbNullString)
.Location = Nz(Me.txtLocation,  vbNullString)

If  Me.chkApptReminder = True  Then
If IsNull(Me.txtReminderMinutes)  Then
Me.txtReminderMinutes.Value =  30
End  If
.ReminderOverrideDefault =  True
.ReminderMinutesBeforeStart =  Me.txtReminderMinutes
.ReminderSet =  True
End  If
' Save the Appointment Item  Properties
.Save
End  With
End If
 
    ' Release the Outlook object  variables.
Set olAppt = Nothing
Set  olApp = Nothing
 
    ' Set chkAddedToOutlook to checked
Me.chkAddedToOutlook = True
 
    ' Save the Current Record because we checked  chkAddedToOutlook
If Me.Dirty  Then
Me.Dirty =  False
End If
 
    ' Inform the user
MsgBox  "Appointment Added!", vbInformation
 
End Sub
 
 
 
'---------------------------------------------------------------------------
------------  
' Procedure : isAppThere 
' Author    : Rick Dobson, Ph.D  - Programming Microsoft Access 2000 
' Purpose   : To check if an  Application is Open 
' Arguments : appName The name of the Application 
'  Example   : isAppThere("Outlook.Application")  
'---------------------------------------------------------------------------
------------  
' 
Function isAppThere(appName) As Boolean 
On Error Resume Next  
Dim objApp As Object 

isAppThere = True 

Set objApp = GetObject(, appName)  
If Err.Number <> 0 Then  isAppThere = False 
 

End Function