Sub OpenAppointmentCopy()
Dim objOL As Outlook.Application
Dim objSelection As Outlook.Selection
Dim objItem As Object
Set objOL = Outlook.Application
Dim Result
Select Case TypeName(objOL.ActiveWindow)
Case "Explorer"
Set objSelection = objOL.ActiveExplorer.Selection
If objSelection.count > 0 Then
Set objItem = objSelection.Item(1)
Else
Result = MsgBox("No item selected. " & _
"Please make a selection first.", _
vbCritical, "OpenAppointmentCopy")
Exit Sub
End If
Case "Inspector"
Set objItem = objOL.ActiveInspector.CurrentItem
Case Else
Result = MsgBox("Unsupported Window type." & _
vbNewLine & "Please make a selection" & _
"in the Calendar or open an item first.", _
vbCritical, "OpenAppointmentCopy")
Exit Sub
End Select
Dim olAppt As Outlook.AppointmentItem
Dim olApptCopy As Outlook.AppointmentItem
Set olApptCopy = Outlook.CreateItem(olAppointmentItem)
If objItem.Class = olAppointment Then
Set olAppt = objItem
With olApptCopy
.Subject = olAppt.Subject
.Location = olAppt.Location
.Body = olAppt.Body
.Categories = olAppt.Categories
.AllDayEvent = olAppt.AllDayEvent
End With
olApptCopy.Display
Else
Result = MsgBox("No appointment item selected. " & _
"Please make a selection first.", _
vbCritical, "OpenAppointmentCopy")
Exit Sub
End If
Set objOL = Nothing
Set objItem = Nothing
Set olAppt = Nothing
Set olApptCopy = Nothing
End Sub