Implementing GTD on Outlook–Part 2

Create appointment directly from the email.
Code for same is given below

   1:  Option Explicit

   2:  Sub NewMeetingRequestFromEmail()

   3:      Dim app As New Outlook.Application

   4:      Dim item As Object

   5:      Set item = app.ActiveInspector.CurrentItem

   6:      

   7:      If item.Class <> olMail Then Exit Sub

   8:      

   9:      Dim email As MailItem

  10:      

  11:      Set email = item

  12:      

  13:      Dim meetingRequest As AppointmentItem

  14:      

  15:      Set meetingRequest = app.CreateItem(olAppointmentItem)

  16:      

  17:      meetingRequest.Categories = email.Categories

  18:      meetingRequest.Body = email.Body

  19:      meetingRequest.Subject = email.Subject

  20:      meetingRequest.Attachments.Add email

  21:      

  22:      Dim attachment As attachment

  23:      For Each attachment In email.Attachments

  24:          CopyAttachment attachment, meetingRequest.Attachments

  25:      Next attachment

  26:      

  27:      Dim recipient As recipient

  28:      

  29:      Set recipient = meetingRequest.Recipients.Add(email.SenderEmailAddress)

  30:      recipient.Resolve

  31:      

  32:      For Each recipient In email.Recipients

  33:          RecipientToParticipant recipient, meetingRequest.Recipients

  34:      Next recipient

  35:      

  36:      Dim inspector As inspector

  37:      

  38:      Set inspector = meetingRequest.GetInspector

  39:          

  40:      'inspector.CommandBars.FindControl

  41:      inspector.Display

  42:      

  43:  End Sub

  44:   

  45:  Private Sub RecipientToParticipant(recipient As recipient, participants As Recipients)

  46:      Dim participant As recipient

  47:      

  48:      If LCase(recipient.Address) <> LCase(Session.CurrentUser.Address) Then

  49:          Set participant = participants.Add(recipient.Address)

  50:          Select Case recipient.Type

  51:          Case olBCC:

  52:              participant.Type = olOptional

  53:          Case olCC:

  54:              participant.Type = olOptional

  55:          Case olOriginator:

  56:              participant.Type = olRequired

  57:          Case olTo:

  58:              participant.Type = olRequired

  59:          End Select

  60:          participant.Resolve

  61:      End If

  62:   

  63:  End Sub

  64:   

  65:  Private Sub CopyAttachment(source As attachment, destination As Attachments)

  66:      On Error GoTo HandleError

  67:      

  68:      Dim filename As String

  69:      

  70:      filename = Environ("temp") & "\" & source.filename

  71:      

  72:      source.SaveAsFile (filename)

  73:      

  74:      destination.Add (filename)

  75:      

  76:      Exit Sub

  77:      

  78:  HandleError:

  79:      Debug.Print Err.Description

  80:  End Sub

  81:   

  82:   

The code will open a pop up with the content from the current email copied to its body. Also the original email copy is attached to it (for future reference)