<code lang="VBA">
Sub CreateEmailTask()   'BETA VERSION

    'Created by Jeremy Edmiston
    'Point Loma Nazarene University
    'Version 0.1.2
    'Updated 7/24/03
    
'    On Error Resume Next

    Dim oExplorer As Outlook.Explorer
    Dim oMessage As Outlook.MailItem
    Dim oTask As Outlook.TaskItem
    Dim msgCount As Integer

    Set oExplorer = Outlook.ActiveExplorer.CurrentFolder.GetExplorer
        
    msgCount = 0
    
    For Each Item In oExplorer.Selection                        'Check items in current folder
        msgCount = msgCount + 1                                 'increase counter
        If oExplorer.Selection.Item(msgCount).Class = 43 Then   'Only do for Mail Items
                Set oMessage = oExplorer.Selection.Item(msgCount)
                Set oTask = Outlook.CreateItem(olTaskItem)
                    
                
                With oTask
                    .Body = oMessage.Body
                    .Importance = oMessage.Importance
                    
                    'Attachment Handler
                    If oMessage.Attachments.Count > 0 Then
                        Dim attCount As Integer
                        attCount = 0

                        'Copy Attachments to new task
                        For Each Attachment In oMessage.Attachments
                            Dim oAttachment As Outlook.Attachment
                            Dim attPath As String
                            Dim attName As String

                            attCount = attCount + 1
                            
'                            MsgBox oMessage.Attachments.Item(attCount).type
                            If Not oMessage.Attachments.Item(attCount).Type = 6 Then
                            
                                attPath = "C:\"
                                attName = oMessage.Attachments.Item(attCount).FileName
    
                                oMessage.Attachments.Item(attCount).SaveAsFile (attPath & attName)
                                oTask.Attachments.Add (attPath & attName)
                            Else
                                MsgBox ("This type of attachment cannot be embedded in the task." & _
                                        vbCrLf & vbCrLf & _
                                        "However, it is still in the attached Original Message.")
                            End If
                        Next
                    End If
                    
                    'Flag Handler
                    If oMessage.FlagStatus = 2 Then     'Message is flagged
'                        MsgBox oMessage.FlagRequest
                        Select Case oMessage.FlagRequest
                            Case "Follow up"
                                .Subject = "Follow up with " & oMessage.SenderName & _
                                            " about " & oMessage.Subject & " (e-mail)"
                            Case "Call"
                                .Subject = "Call " & oMessage.SenderName & _
                                            " about " & oMessage.Subject & " (e-mail)"
                            Case Else
'                                MsgBox oMessage.FlagRequest
                        End Select
                                .ReminderSet = True
                                .ReminderTime = oMessage.FlagDueBy
                                .DueDate = oMessage.FlagDueBy
                    Else
                        .Subject = oMessage.Subject
                    End If
                    
                    .Contacts = oMessage.SenderName
                    
                    'Save Message Copy
                    oMessage.SaveAs attPath & oMessage.EntryID
                    
                    'Attach Message Copy as Original Message
                    oTask.Attachments.Add attPath & oMessage.EntryID, olEmbeddeditem, , "Original Message"
                    
                    
                    'Display New Task
                    .Display
                End With
                
                'Delete Original Message
                If MsgBox("Delete the Original Messsage from Inbox?", vbYesNo) = vbYes Then
                    oMessage.Delete
                End If
                
        End If
    Next

End Sub
</code>