Dim objOutlook As Object
Dim sAPPPath As String
Dim objMyMsgItem As Object
Dim objMyApptItem As Object
If IsAppRunning("Outlook.Application") = True Then 'Outlook was already running
Set objOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
Else 'Could not get instance of Outlook, so create a new one
sAPPPath = GetAppExePath("outlook.exe") 'determine outlook's installation path
Shell (sAPPPath) 'start outlook
Do While Not IsAppRunning("Outlook.Application")
DoEvents
Loop
Set objOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
End If
'Create the Message Item and fill the Body text with the formatted text
Set objMyMsgItem = objOutlook.CreateItem(0)
With objMyMsgItem
.HTMLBody = Nz(Me.txtApptNotes, "")
.Display
End With
'Create the Appointment Item and populate all the fields except the body text
Set objMyApptItem = objOutlook.CreateItem(1)
'Now use the WordInspector to copy the formatted text from the Message Item to the Appointment Item.
Dim MyMsgInspector As Object
Dim wdDoc_Msg As Object
Set MyMsgInspector = objMyMsgItem.GetInspector
Set wdDoc_Msg = MyMsgInspector.WordEditor
Dim MyApptInspector As Object
Dim wdDoc_Appt As Object
Set MyApptInspector = objMyApptItem.GetInspector
Set wdDoc_Appt = MyApptInspector.WordEditor
wdDoc_Appt.Range.FormattedText = wdDoc_Msg.Range.FormattedText
'Now close the message item and discard
objMyMsgItem.Close (olDiscard)
'Set up the appointment with the correct fields
With objMyApptItem
.ReminderOverrideDefault = True
.ReminderSet = True
.ReminderMinutesBeforeStart = Me.ApptRemindBeforehand
.Subject = Nz(Me.txtApptSubject, "")
.Location = Nz(Me.txtApptLocation, "")
.Start = Me.txtApptStart
.End = Me.txtApptEnd
.Duration = Me.txtApptDurationMinutes
.AllDayEvent = Me.chkAllDayEvent
.Importance = Me.cboApptImportance
.BusyStatus = Me.cboApptShowTimeAs
.Mileage = Me.txtApptID 'Store the appointment id in the mileage field for later reference, changes etc.
'Now determine whether to save or send
If IsNull(Me.txtApptAttendees) = False Then
If Me.txtApptAttendees <> "" Then
.MeetingStatus = olMeeting
.RequiredAttendees = Nz(Me.txtApptAttendees, "")
.Send
Else
.Save
End If
Else
.Save
End If
End With