Outlook macro: Create appointment from e-mail.

CreateAppointmentFromMessage.vb

Option Explicit

Sub CreateAppointmentFromMessage()

    Dim activeWin As Object
    Dim targetItem As Object
    Dim targetMsg As MailItem
    Dim targetFolder As Folder
    Dim newAppointment As AppointmentItem
    Dim msgInspector As Inspector
    Dim aptInspector As Inspector
    Dim wordEdit As Object
    Dim oldInspectorCount As Integer
    Dim newInspectorCount As Integer

    Set activeWin = Application.ActiveWindow
    ' Case 1: Calling this from the message window.
    If activeWin.Class = olInspector Then
        Set targetItem = activeWin.CurrentItem
        If targetItem.Class <> olMail Then
            MsgBox "The current item is not a message.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetMsg = targetItem
    ' Case 2: Calling this from the folder window.
    ElseIf activeWin.Class = olExplorer Then
        ' Ensure current folder is a folder of messages.
        Set targetFolder = activeWin.CurrentFolder
        If targetFolder Is Nothing Then
            MsgBox "No folder is in view.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        If targetFolder.DefaultItemType <> olMailItem Then
            MsgBox "The current folder is not a message folder.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetFolder = Nothing
        ' Ensure the unique selection is a message.
        Set targetItem = activeWin.Selection
        If targetItem.Count = 0 Then
            MsgBox "No item is selected.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        ElseIf targetItem.Count <> 1 Then
            MsgBox "Multiple items are selected.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetItem = targetItem.Item(1)
        If targetItem.Class <> olMail Then
            MsgBox "The selected item is not a message.", vbExclamation, "Create Appointment from Message"
            Exit Sub
        End If
        Set targetMsg = targetItem
    ' Case 3: Mysterious.
    Else
        MsgBox "The active window is neither an inspector not an explorer.", vbExclamation, "Create Appointment from Message"
        Exit Sub
    End If

    ' Ask the user to choose a calendar.
    Set targetFolder = Application.GetNamespace("MAPI").PickFolder
    If targetFolder Is Nothing Then
        Exit Sub
    End If
    If targetFolder.Class <> olFolder Or targetFolder.DefaultItemType <> olAppointmentItem Then
        MsgBox "The selected folder is not a calendar.", vbExclamation, "Create Appointment from Message"
        Exit Sub
    End If

    Set newAppointment = targetFolder.Items.Add(olAppointmentItem)
    newAppointment.Subject = targetMsg.Subject
    Set aptInspector = newAppointment.GetInspector

    ' Open or retrieve the inspector for the message.
    oldInspectorCount = Application.Inspectors.Count
    Set msgInspector = targetMsg.GetInspector
    newInspectorCount = Application.Inspectors.Count

    ' Copy the message body to the appointment.
    If msgInspector.IsWordMail And (msgInspector.EditorType = olEditorWord) And aptInspector.IsWordMail And (aptInspector.EditorType = olEditorWord) Then
        Set wordEdit = msgInspector.WordEditor
        wordEdit.Select
        wordEdit.Application.Selection.Copy
        Set wordEdit = aptInspector.WordEditor
        wordEdit.Select
        ' 16 = wdFormatOriginalFormatting
        wordEdit.Application.Selection.PasteAndFormat 16
        ' Move the cursor to the beginning.
        wordEdit.Range(0, 0).Select
    ElseIf (msgInspector.EditorType = olEditorWord) Or (msgInspector.EditorType = olEditorRTF) Or (msgInspector.EditorType = olEditorHTML) Then
        newAppointment.RTFBody = targetMsg.RTFBody
    Else
        newAppointment.Body = targetMsg.Body
    End If

    ' Close the message inspector if it was not open.
    If oldInspectorCount <> newInspectorCount Then
        msgInspector.Close olDiscard
    End If

    aptInspector.Activate

End Sub