Option Explicit
Public Sub AddCalendarEntry()
Const mailItem_c As String = "MailItem"
Dim OE As Outlook.Explorer
Dim MI As Outlook.MailItem
Dim AI As Outlook.AppointmentItem
Dim TI As Outlook.TaskItem
Set OE = Application.ActiveExplorer
If OE.Selection.Count < 1 Then
MsgBox "Please select an already saved message before" & vbCrLf & _
"attempting to create an appointment or task" & vbCrLf & _
"with this button ...", vbInformation, "No message selected ..."
Exit Sub
ElseIf TypeName(OE.Selection(1)) <> mailItem_c Then
MsgBox "You must select a mail item...", vbInformation, "Invalid selection..."
Exit Sub
End If
Set MI = OE.Selection(1)
Beep
Select Case MsgBox("Is calendar entry an appointment?" & vbLf & _
"To Add Appointment (Yes) / To Add Task (No) / To Quit (Cancel)" & _
vbCrLf, vbYesNoCancel + vbQuestion, "Create an appointment or task ...")
Case vbYes
Set AI = Outlook.CreateItem(olAppointmentItem)
With AI
.Subject = MI.Subject
.Body = MI.Body
.Save
.Display
End With
Case vbNo
Set TI = Application.CreateItem(olTaskItem)
With TI
.Subject = MI.Subject
.Body = MI.Body
.StartDate = Date
.DueDate = Date + 1
.ReminderTime = .DueDate & " 10:00"
.Save
.Display
End With
End Select
End Sub
|