Below are two groups of functions/subs that I use to create
AppointmentItems on my Outlook calendar from within Access. The Outlook
functions further below, allow me to change the Date/Time of the
AppointmentItem via click and drag or updating the info on the form
itself and have the update cascade back to Access. The
createOutlookAppointmentFromId should show you have to put the patients
name into the SUBJECT of the AppointmentItem.
Notes:
-The change/update functions are designed to be called from ANY form.
Simply provide the RECORD ID and the form name (or null).
-The code provided uses an external sub loadTransport() to get the
information for the transport and load up the global variables
designated by the glb_ prefix.
-GetBodyText() puts the details of the reservation into the body of the
AppointmentItem for reference
-The .UserProperties capture info from Access for which Outlook does not
have an existing field. The information is placed into corresponding
User-Defined fields. One of the values is the KEY for in Access which
allows the information in Access to be updated when the OUTLOOK
appointment is changed.
That should put you in pretty good shape.
David H
---ACCESS FUNCTIONS---
Option Compare Database
Option Explicit
Private Function getBodyText(lngTransportID As Long)
Dim rsClients As Recordset
Dim strBodyText As String
Dim strSQL As String
strBodyText = ""
strBodyText = strBodyText & "Current as of: " &
UCase(Format(glb_dteLastModified, "ddd mm/dd/yy hh:nn am/pm")) & Chr(13)
& Chr(10)
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
strBodyText = strBodyText & "Date/Time: " & glb_dteDate & " " &
glb_dteTimeScheduled & Chr(13) & Chr(10)
'strBodyText = strBodyText & "Passenger: " & strPrimaryPassenger &
" (Primary)" & Chr(13) & Chr(10)
strBodyText = strBodyText & "Name Sign: " & glb_strNameSign &
Chr(13) & Chr(10)
strBodyText = strBodyText & "Status: " &
DLookup("txtStatusDescription", "tblStatusCodes", "txtStatus = '" &
glb_strStatus & "'") & Chr(13) & Chr(10)
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
strBodyText = strBodyText & "From: " & glb_strOrigination & Chr(13)
& Chr(10)
strBodyText = strBodyText & "To: " & glb_strDestination & Chr(13) &
Chr(10)
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
Select Case glb_strSellingPrice
Case "R"
strBodyText = strBodyText & "Selling Price:Retail " &
Chr(13) & Chr(10)
strBodyText = strBodyText & "Fare: " & Format(glb_curFare,
"Currency") & " / "
strBodyText = strBodyText & "Tip: " & Format(glb_curTip,
"Currency") & Chr(13) & Chr(10)
Case "W"
strBodyText = strBodyText & "Selling Price: Wholesale " &
Chr(13) & Chr(10)
strBodyText = strBodyText & "Fare: " &
Format(glb_curFareWholesale, "Currency") & " / "
strBodyText = strBodyText & "Tip: " &
Format(glb_curTipWholesale, "Currency") & Chr(13) & Chr(10)
End Select
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
Select Case glb_strBuyingPrice
Case "R"
strBodyText = strBodyText & "Buying Price: Retail " &
Chr(13) & Chr(10)
strBodyText = strBodyText & "Fare: " & Format(glb_curFare,
"Currency") & " / "
strBodyText = strBodyText & "Tip: " & Format(glb_curTip,
"Currency") & Chr(13) & Chr(10)
Case "W"
strBodyText = strBodyText & "Buying Price: Wholesale " &
Chr(13) & Chr(10)
strBodyText = strBodyText & "Fare: " &
Format(glb_curFareWholesale, "Currency") & " / "
strBodyText = strBodyText & "Tip: " &
Format(glb_curTipWholesale, "Currency") & Chr(13) & Chr(10)
End Select
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
strBodyText = strBodyText & "Vehicle: " &
DLookup("txtVehicleDescription", "tblVehicleTypes", "txtVehicleType = '"
& glb_strVehicleType & "'") & Chr(13) & Chr(10)
strBodyText = strBodyText & "Party Size: " &
glb_intNumberOfPassengers & Chr(13) & Chr(10)
strBodyText = strBodyText & "Car Seat: " & glb_ynCarSeat & Chr(13)
& Chr(10)
If glb_intNumberOfPassengers = 0 Then
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) &
Chr(10)
strBodyText = strBodyText & "PASSENGER INFORMATION NOT
AVAILABLE" & Chr(13) & Chr(10)
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) &
Chr(10)
Else
'MARK - create loadPassenger global variables to eliminate this
strSQL = ""
strSQL = strSQL & "SELECT tblTransferGuests.ynPrimaryPassenger,
tblTransferGuests.lngTransportID, "
strSQL = strSQL & "[txtClientLastName] & ', ' &
[txtClientFirstName] AS txtClientName, tblTransferGuests.txtAirline, "
strSQL = strSQL & "tblTransferGuests.txtFlightNumber ,
tblTransferGuests.dteFlightTime, tblClients.txtClientPhoneMobile,
tblTransferGuests.txtCity "
strSQL = strSQL & "FROM tblTransferGuests LEFT JOIN tblClients
ON tblTransferGuests.lngClientId = tblClients.lngClientID "
strSQL = strSQL & "WHERE (((tblTransferGuests.lngTransportId) =
" & lngTransportID & ")) "
strSQL = strSQL & "ORDER BY
tblTransferGuests.ynPrimaryPassenger, tblTransferGuests.lngTransportID, "
strSQL = strSQL & "[txtClientLastName] & ', ' &
[txtClientFirstName], tblClients.txtClientLastName,
tblClients.txtClientFirstName;"
Set rsClients = CurrentDb.OpenRecordset(strSQL, dbOpenForwardOnly)
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) &
Chr(10)
strBodyText = strBodyText & "Passengers:" & Chr(13) & Chr(10)
While Not rsClients.EOF
strBodyText = strBodyText &
StrConv(rsClients!txtClientName, vbProperCase)
If IsNull(rsClients!txtClientPhoneMobile) = False Then
strBodyText = strBodyText & " " &
Format(rsClients!txtClientPhoneMobile, "(000) 000-0000")
End If
strBodyText = strBodyText & Chr(13) & Chr(10)
If glb_ynAirportArrival = True And _
IsNull(rsClients!dteFlightTime) = False And _
IsNull(rsClients!txtAirline) = False And _
IsNull(rsClients!txtFlightNumber) = False Then
strBodyText = strBodyText & " " &
Format(rsClients!dteFlightTime, "hh:nn AM/PM") & ": "
strBodyText = strBodyText & rsClients!txtAirline & "
#" & rsClients!txtFlightNumber
strBodyText = strBodyText & " " & rsClients!txtCity &
Chr(13) & Chr(10)
End If
rsClients.MoveNext
Wend
End If
'MARK Will need to add function to get the COMMENTS & REMARKS
Set rsClients = Nothing
getBodyText = strBodyText
End Function
Function createOutlookAppointmentFromId(lngTransportID As Long, frm As
Variant)
Dim objOutlook As Outlook.Application
Dim newAppt As Outlook.AppointmentItem
DoCmd.Hourglass (True)
If IsNull(frm) = False Then
frm!txtAdvisory = "Looking up appointment details from database"
frm.Repaint
End If
If IsNull(frm) = False Then
frm!txtAdvisory = "Accessing Outlook"
frm.Repaint
End If
Set objOutlook = CreateObject("Outlook.application")
Set newAppt = objOutlook.CreateItem(olAppointmentItem)
newAppt.UserProperties.Add "dbAccessID", olNumber
newAppt.UserProperties.Add "dbLastModified", olDateTime
newAppt.UserProperties.Add "dbStatus", olText
If IsNull(frm) = False Then
frm![txtAdvisory] = "Creating new appointment"
frm.Repaint
End If
Call loadTransport(lngTransportID)
With newAppt
.Start = glb_dteDate & " " & glb_dteTimeScheduled
.End = glb_dteDate & " " & DateAdd("h", 1,
CDate(glb_dteTimeScheduled))
.Subject = "strPrimaryPassenger Name Here"
.Location = glb_strOrigination & " - " & glb_strDestination
.UserProperties(1) = lngTransportID
.UserProperties(2) = Now
.UserProperties(3) = DLookup("txtStatusDescription",
"tblStatusCodes", "txtStatus = '" & glb_strStatus & "'")
.Body = getBodyText(lngTransportID)
.BusyStatus = olBusy
.Categories = "Reservations"
.MessageClass = "IPM.Appointment.Reservations"
.Save
createOutlookAppointmentFromId = newAppt.EntryID
End With
On Error GoTo 0
If IsNull(frm) = False Then
frm![txtAdvisory] = "New appointment created"
frm.Repaint
End If
If Err.Number <> 0 Then createOutlookAppointmentFromId = Null
DoCmd.Hourglass (False)
Set newAppt = Nothing
Set objOutlook = Nothing
Call clearTransport
If IsNull(frm) = False Then
frm![txtAdvisory] = ""
frm.Repaint
End If
End Function
Function changeOutlookAppointmentFromId(lngTransportID As Long, frm As
Variant)
Select Case deleteOutlookAppointmentByTransportId(lngTransportID, Null)
Case 0, -1
changeOutlookAppointmentFromId =
createOutlookAppointmentFromId(lngTransportID, Null)
Case Else
changeOutlookAppointmentFromId = Null
End Select
End Function
Function deleteOutlookAppointmentByTransportId(lngTransportID As Long,
frm As Variant)
Dim objOutlook As Outlook.Application
Dim nms As Outlook.NameSpace
Dim targetCalendar As Outlook.MAPIFolder
Dim targetItems As Outlook.Items
Dim i As Integer
Dim aOutlookEntryIds()
Dim targetAppointment As Outlook.AppointmentItem
Dim strFilter As String
Set objOutlook = CreateObject("Outlook.application")
Set nms = objOutlook.GetNamespace("MAPI")
Set targetCalendar = nms.GetDefaultFolder(olFolderCalendar)
strFilter = "[dbAccessId]=" & Chr(34) & lngTransportID & Chr(34)
Set targetItems = targetCalendar.Items.Restrict(strFilter)
ReDim aOutlookEntryIds(targetItems.Count)
For i = 1 To targetItems.Count
Debug.Print i
aOutlookEntryIds(i) = targetItems(i).EntryID
Next i
Select Case targetItems.Count
Case 0
Debug.Print "AppointmentItem not found."
deleteOutlookAppointmentByTransportId = 0
Case Else
Debug.Print targetItems.Count & " AppointmentItem(s) found.
Deleting all instances."
For i = 1 To targetItems.Count
Set targetAppointment =
nms.GetItemFromID(aOutlookEntryIds(i))
Debug.Print targetAppointment.UserProperties(1),
targetAppointment.Start, targetAppointment.Subject
targetAppointment.Delete
Debug.Print "Appoint ID: " & aOutlookEntryIds(i) & "
Deleted"
Debug.Print
Next i
deleteOutlookAppointmentByTransportId = -1
End Select
Set targetItems = Nothing
Set targetCalendar = Nothing
Set nms = Nothing
Set objOutlook = Nothing
End Function
---OUTLOOK CODE---
Dim myOlApp As New Outlook.Application
Public WithEvents myOlItems As Outlook.Items
Public Sub Application_Startup()
Call Initialize_handler
End Sub
Public Sub Initialize_handler()
Set myOlItems =
myOlApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
Debug.Print "Initialize_Handler"
End Sub
Private Sub myOlItems_ItemChange(ByVal Item As Object)
Dim objAccess As Object
Dim db As DAO.Database
Dim rs As DAO.Recordset
DoCmd.Hourglass True
If Item.Class = olAppointment And Item.MessageClass =
"IPM.Appointment.Reservations" Then
If IsNull(Item.UserProperties("dbAccessId")) = False Then
Set objAccess = CreateObject("Access.Application")
Set db = objAccess.DBEngine.OpenDatabase("C:\Documents and
Settings\dch3\My Documents\Willard Madison\Data\Access\WMS FrontEnd
2005.mdb")
Set rs = db.OpenRecordset("SELECT * FROM tblTransports
WHERE lngTransportID = " & Item.UserProperties("dbAccessID") & ";")
If Not rs.EOF Then
rs.Edit
rs.Fields("dteDate") = FormatDateTime(Item.Start,
vbShortDate)
rs.Fields("dteTimeScheduled") =
FormatDateTime(Item.Start, vbShortTime)
rs.Update
MsgBox ("Transport #" &
Item.UserProperties("dbAccessID") & " updated.")
Else
MsgBox ("Unable to update Transport #" &
Item.UserProperties("dbAccessID") & ". Record may have been deleted.")
End If
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
Set objAccess = Nothing
End If
End If
DoCmd.Hourglass False
End Sub
