createOutlookAppointment() does just that. getBodyText() builds the text
for the message including hitting the database for information to be
included. Not going to add comments since its late, but you'll be most
interested in the SET statements at the begning as they create the new
appointment. Let me know if you have questions.
Sub createOutlookAppointment()
Dim objOutlook As Outlook.Application
Dim nms As Outlook.NameSpace
Dim mailbox As MAPIFolder
Dim targetCalendar As MAPIFolder
Dim newAppt As Outlook.AppointmentItem
Dim strLocation As String
Dim strPrimaryPassenger As String
If [Forms]![frmReservations]![txtOutlookEntryId] = "" Or
IsNull([Forms]![frmReservations]![txtOutlookEntryId]) = True Then
DoCmd.Hourglass (True)
[Forms]![frmReservations]![txtAdvisory] = "Accessing Outlook..."
[Forms]![frmReservations].Repaint
Set objOutlook = CreateObject("Outlook.application")
Set nms = objOutlook.GetNamespace("MAPI")
Set mailbox = nms.Folders(1)
Set targetCalendar = mailbox.Folders("Calendar")
Set newAppt = objOutlook.CreateItem(olAppointmentItem)
newAppt.UserProperties.Add "dbAccessID", olNumber
newAppt.UserProperties.Add "dbLastModified", olDateTime
newAppt.UserProperties.Add "dbStatus", olText
strLocation = DLookup("txtLocationShortDescription",
"tblLocations", "[lngLocationKey] =
[Forms]![frmReservations]![cboOrigination]")
strLocation = strLocation & " - "
strLocation = strLocation &
DLookup("txtLocationShortDescription", "tblLocations", "[lngLocationKey]
= [Forms]![frmReservations]![cboDestination]")
[Forms]![frmReservations]![txtAdvisory] = "Creating new
appointment..."
[Forms]![frmReservations].Repaint
If IsNull([Forms]![frmReservations]![txtPrimaryPassengerName])
= True Or _
[Forms]![frmReservations]![txtPrimaryPassengerName] = "" Then
strPrimaryPassenger = "-NTF-"
Else
strPrimaryPassenger =
[Forms]![frmReservations]![txtPrimaryPassengerName]
End If
With newAppt
.Start = [Forms]![frmReservations]![dteDate] & " " &
[Forms]![frmReservations]![dteTimeScheduled]
.End = [Forms]![frmReservations]![dteDate] & " " &
DateAdd("h", 1, CDate([Forms]![frmReservations]![dteTimeScheduled]))
.Subject = strPrimaryPassenger
.Location = strLocation
.UserProperties(1) = [Forms]![frmReservations]![lngTransportID]
.UserProperties(2) = Now
.UserProperties(3) =
[Forms]![frmReservations]![cboStatus].Column(1)
.Body = getBodyText()
.BusyStatus = olBusy
.Categories = "Reservations"
.MessageClass = "IPM.Appointment.Reservations"
.Save
End With
[Forms]![frmReservations]![txtAdvisory] = "New appointment created"
[Forms]![frmReservations].Repaint
[Forms]![frmReservations]![txtOutlookEntryId] = newAppt.EntryID
DoCmd.Hourglass (False)
If IsNull(newAppt.EntryID) = False Then
[Forms]![frmReservations]![dteOutlookLastUpdated] = Now()
MsgBox ("Outlook appointment created.")
Else
MsgBox ("Unable to confirm that the Outlook appointment was
created.")
End If
Set newAppt = Nothing
Set targetCalendar = Nothing
Set mailbox = Nothing
Set nms = Nothing
Set objOutlook = Nothing
Else
MsgBox ("An Outlook appointment has already been scheduled for
this reservation.")
End If
[Forms]![frmReservations]![txtAdvisory] = ""
End Sub
Function getBodyText()
Dim qdfClients As QueryDef
Dim rsClients As Recordset
strBodyText = ""
strBodyText = strBodyText & "Current as of: " &
UCase(Format([Forms]![frmReservations]![dteLastModified], "ddd mm/dd/yy
hh:nn am/pm")) & Chr(13) & Chr(10)
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
strBodyText = strBodyText & "Date/Time: " &
[Forms]![frmReservations]![dteDate] & " " &
[Forms]![frmReservations]![dteTimeScheduled] & Chr(13) & Chr(10)
strBodyText = strBodyText & "Passenger: " &
[Forms]![frmReservations]![txtPrimaryPassengerName] & " " &
Format([Forms]![frmReservations]![txtPrimaryPassengerPhone], "(000)
000-0000") & Chr(13) & Chr(10)
strBodyText = strBodyText & "Name Sign: " &
[Forms]![frmReservations]![txtNameSign] & Chr(13) & Chr(10)
strBodyText = strBodyText & "Status: " &
[Forms]![frmReservations]![cboStatus].Column(1) & Chr(13) & Chr(10)
If IsNull([Forms]![frmReservations]![txtContactNameFirst]) = False
And _
IsNull([Forms]![frmReservations]![txtContactNameLast]) = False
And _
IsNull([Forms]![frmReservations]![txtContactPhone]) = False Then
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) &
Chr(10)
strBodyText = strBodyText & "Contact: " &
[Forms]![frmReservations]![txtContactNameFirst] & " " &
[Forms]![frmReservations]![txtContactNameLast] & Chr(13) & Chr(10)
strBodyText = strBodyText & "Phone: " &
Format([Forms]![frmReservations]![txtContactPhone], "(000) 000-0000") &
Chr(13) & Chr(10)
End If
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
strBodyText = strBodyText & "From: " &
[Forms]![frmReservations]![cboOrigination].Column(1) & Chr(13) & Chr(10)
strBodyText = strBodyText & "To: " &
[Forms]![frmReservations]![cboDestination].Column(1) & Chr(13) & Chr(10)
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
Select Case [Forms]![frmReservations]![cboSellingPrice]
Case "R"
strBodyText = strBodyText & "Selling Price:Retail "
strBodyText = strBodyText & "("
strBodyText = strBodyText & "Fare: " &
Format([Forms]![frmReservations]![curFare], "Currency") & " / "
strBodyText = strBodyText & "Tip: " &
Format([Forms]![frmReservations]![curTip], "Currency")
strBodyText = strBodyText & ")" & Chr(13) & Chr(10)
Case "W"
strBodyText = strBodyText & "Selling Price: Wholesale "
strBodyText = strBodyText & "("
strBodyText = strBodyText & "Fare: " &
Format([Forms]![frmReservations]![curFareWholesale], "Currency") & " / "
strBodyText = strBodyText & "Tip: " &
Format([Forms]![frmReservations]![curTipWholesale], "Currency")
strBodyText = strBodyText & ")" & Chr(13) & Chr(10)
End Select
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
Select Case [Forms]![frmReservations]![cboPurchasePrice]
Case "R"
strBodyText = strBodyText & "Buying Price: Retail "
strBodyText = strBodyText & "("
strBodyText = strBodyText & "Fare: " &
Format([Forms]![frmReservations]![curFare], "Currency") & " / "
strBodyText = strBodyText & "Tip: " &
Format([Forms]![frmReservations]![curTip], "Currency")
strBodyText = strBodyText & ")" & Chr(13) & Chr(10)
Case "W"
strBodyText = strBodyText & "Buying Price: Wholesale "
strBodyText = strBodyText & "("
strBodyText = strBodyText & "Fare: " &
Format([Forms]![frmReservations]![curFareWholesale], "Currency") & " / "
strBodyText = strBodyText & "Tip: " &
Format([Forms]![frmReservations]![curTipWholesale], "Currency")
strBodyText = strBodyText & ")" & Chr(13) & Chr(10)
End Select
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) & Chr(10)
strBodyText = strBodyText & "Vehicle: " &
[Forms]![frmReservations]![cboVehicleType].Column(1) & Chr(13) & Chr(10)
strBodyText = strBodyText & "Party Size: " &
[Forms]![frmReservations]![intNumberofPassengers] & Chr(13) & Chr(10)
strBodyText = strBodyText & "Car Seat: " &
[Forms]![frmReservations]![cboCarSeat].Column(1) & Chr(13) & Chr(10)
If countTransferGuests([Forms]![frmReservations]![lngTransportID])
= 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
Set qdfClients = CurrentDb.QueryDefs("qrySelectTransferGuests")
qdfClients.Parameters(0) =
[Forms]![frmReservations]![lngTransportID]
Set rsClients = qdfClients.OpenRecordset(dbOpenForwardOnly)
strBodyText = strBodyText & "--- --- --- --- ---" & 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 [Forms]![frmReservations]![ynAirportTransfer] = 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
If IsNull([Forms]![frmReservations]![txtComments]) = False Then
strBodyText = strBodyText & "--- --- --- --- ---" & Chr(13) &
Chr(10)
strBodyText = strBodyText & "Comments:" & Chr(13) & Chr(10)
strBodyText = strBodyText & [Forms]![frmReservations]![txtComments]
End If
Set rsClients = Nothing
Set qdfClients = Nothing
getBodyText = strBodyText
End Function
