Create appointment from mail (Outlook 2013)

CreateAppointment.vba

Sub CreateAppointmentFromMail()
    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
     
     'Abort sub if no item selected:
    If OE.Selection.Count < 1 Then
        MsgBox "Please select an already saved message before" & vbCrLf & _
        "attempting to create an appointment" & vbCrLf & _
        "with this button ...", vbInformation, "No message selected ..."
        Exit Sub
         'Abort sub if item selected is not a MailItem.
    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)
    Set AI = Outlook.CreateItem(olAppointmentItem)
    With AI
            .Subject = MI.Subject

            .Body = .Body & MI.Body
            '.StartDate = Date
            '.DueDate = Date + 1
            '.ReminderTime = .DueDate & " 10:00"

    'AI.Body = "View Original Mail attacched at the bottom" & vbCrLf & AI.Body
    '
    Dim num As Integer
    num = 0
    Dim attachment As attachment
    For Each attachment In MI.Attachments
        CopyAttachment attachment, AI.Attachments
        num = num + 1
    Next attachment
    
    .Body = .Body & "-----Message Information-----" & vbCrLf
    .Body = .Body & "From: " & MI.Sender & vbCrLf
    .Body = .Body & "Sent: " & Format(MI.SentOn, "DD MMMM YYYY HH:MM:SS") & vbCrLf
    .Body = .Body & "To: " & MI.To & vbCrLf
    .Body = .Body & "Cc: " & MI.CC & vbCrLf
    .Body = .Body & "-----------------------------" & vbCrLf
    AI.Attachments.Add MI, , num 'Position does not work. It is a bug in Outlook 2008/2010
    AI.Display
    End With
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olInbox As Outlook.MAPIFolder
    Dim existingItems As Outlook.Items
    
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    
    Set olInbox = objNS.GetDefaultFolder(olFolderInbox)
    Set existingItems = olInbox.Items
    
    Dim moveItem As Boolean
    moveItem = False
    For Each myItem In existingItems
        If (myItem.Class = olMail) Then
            If (myItem.Subject = MI.Subject) Then
                moveItem = True
            End If
        End If
    Next
    
    If (moveItem) Then
        Dim olFolder As Outlook.MAPIFolder
        Set olFolder = olInbox.Folders("00 TODO")
        MI.Move olFolder
    End If
    

    
End Sub


Private Sub CopyAttachment(source As attachment, destination As Attachments)
    On Error GoTo HandleError
    
    Dim filename As String
    
    filename = Environ("temp") & "\" & source.filename
    
    source.SaveAsFile (filename)
    
    destination.Add (filename)
    
    Exit Sub
    
HandleError:
    Debug.Print Err.Description
End Sub