[AccessD] Access to Outlook Calendar

John:

That was actually the site I cribbed the code from.  What I can't figure out
is how to point to a different Outlook calendar.  In this code I think the
calendar that's pointed to is the one in the default Outlook by:

Set olApp =  CreateObject("Outlook.Application")

Thanks and regards,

Rocky



-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of
Johncliviger at aol.com
Sent: Tuesday, June 16, 2009 1:41 AM
To: accessd at databaseadvisors.com
Subject: Re: [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 
 


--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com