Attribute VB_Name = "Module1"
Option Explicit

' Create a New Meeting request from an email
' Written by Michael S. Scherotter (mischero@microsoft.com)
' Revision History
' 2008-04-23 MSS Added logic to get the item in the preview pane
' What this code does
' 1. If there is no active inspector and the preview pane is open get the first selected item
' 1.1 If there is an active inspector, get the item it's inspecting
' 1.2 If the item is an email, create a new appointment item
' 2. Copy the categories, body, and subject
' 3. Copy the attachments
' 4. Add the sender as a meeting participant
' 5. Add each email recipient as a meeting participant
' 6.    Each To: participant will be required
' 7.    Each CC: or BCC: participant will be optional
Sub NewMeetingRequestFromEmail()
    Dim app As New Outlook.Application
    Dim item As Object
    
    If app.ActiveInspector Is Nothing Then
        If app.ActiveExplorer.IsPaneVisible(olPreview) Then
            Set item = app.ActiveExplorer.Selection.item(1)
        End If
    Else
        Set item = app.ActiveInspector.CurrentItem
    End If
    
    If item Is Nothing Then Exit Sub
    
    If item.Class <> olMail Then Exit Sub
    
    Dim email As MailItem
    
    Set email = item
    
    Dim meetingRequest As AppointmentItem
    
    Set meetingRequest = app.CreateItem(olAppointmentItem)
    
    meetingRequest.Categories = email.Categories
    meetingRequest.Body = email.Body
    meetingRequest.Subject = email.Subject
    
    Dim attachment As attachment
    For Each attachment In email.Attachments
        CopyAttachment attachment, meetingRequest.Attachments
    Next attachment
    
    Dim recipient As recipient
    
    Set recipient = meetingRequest.Recipients.Add(email.SenderEmailAddress)
    recipient.Resolve
    
    For Each recipient In email.Recipients
        RecipientToParticipant recipient, meetingRequest.Recipients
    Next recipient
    
    Dim inspector As inspector
    
    Set inspector = meetingRequest.GetInspector
        
    'inspector.CommandBars.FindControl
    inspector.Display
    
End Sub

Private Sub RecipientToParticipant(recipient As recipient, participants As Recipients)
    Dim participant As recipient
    
    If LCase(recipient.Address) <> LCase(Session.CurrentUser.Address) Then
        Set participant = participants.Add(recipient.Address)
        Select Case recipient.Type
        Case olBCC:
            participant.Type = olOptional
        Case olCC:
            participant.Type = olOptional
        Case olOriginator:
            participant.Type = olRequired
        Case olTo:
            participant.Type = olRequired
        End Select
        participant.Resolve
    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