Microsoft Access to Microsoft Outlook (1 Viewer)

[learnaccesscg]

I have been able to successfully set up code to be able to add appointments to microsoft outlook based on data within a few forms that I have. My question is this however, how do I get access to make that appointment to a specific calendar on outlook. This calendar is a shared calendar. Currently, access is just adding the appointments to "My Calendar" and I could like it to place the appointment on "HVCalendar".

a version of the code I found online is listed below:

' You are welcome to use this code if you leave all authorship information intact
'---------------------------------------------------------------------------------------
' Procedure : btnAddApptToOutlook_Click
' DateTime : 7/09/2009
' Author : Patrick Wood
' Purpose : Add an Access Appointment Record to the Outlook Calendar
'---------------------------------------------------------------------------------------
'
Private Sub btnaddappttooutlook_Click()
'On Error GoTo ErrHandle

Dim olNS As Object
Dim olApptFldr As Object

' Save the Current Record
If Me.Dirty Then Me.Dirty = False

' 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

' 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 olApp As Outlook.Application
' Dim olappt As Outlook.AppointmentItem
' Set olapp = CreateObject("Outlook.Application")
' Set olappt = olapp.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

Set olAppt = olApp.CreateItem(1) ' 1 = olAppointmentItem

' Add the Form data to the Appointment Properties
With olAppt
If Nz(Me.chkallDayEvent) = True Then
.Alldayevent = True

' Format the dates in the Form Controls
Me.txtStartDate = FormatDateTime(Me.txtStartDate, vbShortDate)
Me.TxtEndDate = FormatDateTime(Me.TxtEndDate, vbShortDate)
' For all day events use "" for the start time and the end time
Me.cboStarttime = ""
Me.cboendtime = ""

' Get the Start and the End Dates
Dim dteTempEnd As Date
Dim dteStartDate As Date
Dim dteEndDate As Date
dteStartDate = CDate(FormatDateTime(Me.txtStartDate, vbShortDate)) ' Begining Date of appointment
dteTempEnd = CDate(FormatDateTime(Me.TxtEndDate, vbShortDate)) ' Use to compute End Date of appointment

' Add one day to dteEndDate so Outlook will set the number of days correctly
dteEndDate = DateSerial(Year(dteTempEnd + 1), Month(dteTempEnd + 1), Day(dteTempEnd + 1))

.Start = dteStartDate
.End = dteEndDate

' Set the number of minutes for each day in the AllDayEvent Appointment
Dim lngMinutes As Long

lngMinutes = CDate(Nz(dteEndDate)) - CDate(Nz(dteStartDate))
' The duration in Minutes, 1440 per day
lngMinutes = lngMinutes * 1440

' Add the minutes to the Access Form
Me.txtapptlength.Value = lngMinutes

.Duration = lngMinutes

Else
' The Validation Rule for the Start Date TextBox requires a
' Start Date so there is no need to check for it here
If Len(Me.cboStarttime & vbNullString) = 0 Then
' There is no end time on the Form
' Add vbNullString ("") to avoid an error
Me.cboStarttime = vbNullString
End If

' Set the Start Property Value
.Start = FormatDateTime(Me.txtStartDate, vbShortDate) _
& " " & FormatDateTime(Me.cboStarttime, vbShortTime)

' If there is no End Date on the Form just skip it
If Len(Me.TxtEndDate & vbNullString) > 0 Then
If Len(Me.cboendtime & vbNullString) = 0 Then
' There is no end time on the Form
' Add vbNullString ("") to avoid an error
Me.cboendtime = vbNullString
Else
' Set the End Property Value
.End = FormatDateTime(Me.TxtEndDate, vbShortDate) _
& " " & FormatDateTime(Me.cboendtime, vbShortTime)
End If
End If

If Len(Me.txtapptlength & vbNullString) = 0 Then
Dim timStartTime As Date
Dim timEndTime As Date

' Format the Start Time and End Time
timStartTime = FormatDateTime(Me.txtStartDate, vbShortDate) _
& " " & FormatDateTime(Me.cboStarttime, vbShortTime)
timEndTime = FormatDateTime(Me.TxtEndDate, vbShortDate) _
& " " & FormatDateTime(Me.cboendtime, vbShortTime)

.Duration = Me.txtapptlength
End If
End If

If Nz(Me.chkallDayEvent) = False Then
.Alldayevent = False
End If

If Len(Me.cboapptdescription & vbNullString) > 0 Then
.Subject = Me.cboapptdescription
End If

If Len(Me.txtapptnotes & vbNullString) > 0 Then
.Body = Me.txtapptnotes
End If

If Len(Me.txtlocation & vbNullString) > 0 Then
.Location = Me.txtlocation
End If

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

' Set chkAddedToOutlook to checked
Me.chkAddedToOutlook = True

' Save the Current Record because we checked chkAddedToOutlook
If Me.Dirty Then Me.Dirty = False

' Inform the user
MsgBox "New Outlook Appointment Has Been Added!", vbInformation
End If

ExitHere:
' Release Memory
Set olApptFldr = Nothing
Set olNS = Nothing
Set olAppt = Nothing
Set olApp = Nothing
Exit Sub

ErrHandle:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description _
& vbCrLf & "In procedure btnAddApptToOutlook_Click in Module Module1"
Resume ExitHere

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

 

[mh123]

Hi

I use the following to get the ID for the right calendar to add appts to;

Dim olfolder As Outlook.MAPIFolder
    Dim olapp As Outlook.Application
    Set olapp = CreateObject("Outlook.Application")
    Set olfolder = olapp.GetNamespace("MAPI").PickFolder

then you can print olFolder.entryID here or msgbox it and copy the name ID for it.

Then for instance once you have it you can use this to add your info to the right calendar;

Set olFldr = olapp.GetNamespace("MAPI").GetFolderFromID("XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX(a long ass string here which we got from above)")
Set olAppt = olFldr.Items.Add
rest of your code here to add bits to the appt

This should put you on the right path let me know if you get stuck, gl!