Here it is:

Sub MakeTaskFromMail(olMail As Outlook.MailItem)
   Dim objTask As Outlook.TaskItem
   
   Set objTask = Application.CreateItem(olTaskItem)
   With objTask
       .Subject = olMail.Subject
       .DueDate = DateAddW(olMail.SentOn, 5)
       .ReminderTime = DateAddW(olMail.SentOn, 4)
       .Importance = olImportanceHigh
       .Body = olMail.Body
   End With
   
   Call CopyAttachments(olMail, objTask)
   
   olMail.Delete
   
   objTask.Save
   
   Set objTask = Nothing
   
End Sub

Sub CopyAttachments(objSourceItem, objTargetItem)
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set fldTemp = fso.GetSpecialFolder(2) ' TemporaryFolder
  strPath = fldTemp.Path & "\"
  For Each objAtt In objSourceItem.Attachments
     strFile = strPath & objAtt.FileName
     objAtt.SaveAsFile strFile
     objTargetItem.Attachments.Add strFile, , , objAtt.DisplayName
     fso.DeleteFile strFile
  Next

  Set fldTemp = Nothing
  Set fso = Nothing
End Sub

'========================================================================================================='
'The follwoing code was obtained from:
http://support.microsoft.com/default.aspx?scid=kb%3Ben-us%3B198505
'========================================================================================================='

'========================================================'
' The DateAddW() function provides a workday substitute  '
' for DateAdd("w", number, date). This function performs '
' error checking and ignores fractional Interval values. '
'========================================================'
Function DateAddW(ByVal TheDate, ByVal Interval)

  Dim Weeks As Long, OddDays As Long, Temp As String

  If VarType(TheDate) <> 7 Or VarType(Interval) < 2 Or _
             VarType(Interval) > 5 Then
     DateAddW = TheDate
  ElseIf Interval = 0 Then
     DateAddW = TheDate
  ElseIf Interval > 0 Then
     Interval = Int(Interval)

  ' Make sure TheDate is a workday (round down).

     Temp = Format(TheDate, "ddd")
     If Temp = "Sun" Then
        TheDate = TheDate - 2
     ElseIf Temp = "Sat" Then
        TheDate = TheDate - 1
     End If

  ' Calculate Weeks and OddDays.

     Weeks = Int(Interval / 5)
     OddDays = Interval - (Weeks * 5)
     TheDate = TheDate + (Weeks * 7)

 ' Take OddDays weekend into account.

     If (DatePart("w", TheDate) + OddDays) > 6 Then
        TheDate = TheDate + OddDays + 2
     Else
        TheDate = TheDate + OddDays
     End If

     DateAddW = TheDate
  Else                         ' Interval is < 0
     Interval = Int(-Interval) ' Make positive & subtract later.

  ' Make sure TheDate is a workday (round up).

     Temp = Format(TheDate, "ddd")
     If Temp = "Sun" Then
        TheDate = TheDate + 1
     ElseIf Temp = "Sat" Then
        TheDate = TheDate + 2
     End If

  ' Calculate Weeks and OddDays.

     Weeks = Int(Interval / 5)
     OddDays = Interval - (Weeks * 5)
     TheDate = TheDate - (Weeks * 7)

  ' Take OddDays weekend into account.

     If (DatePart("w", TheDate) - OddDays) > 2 Then
        TheDate = TheDate - OddDays - 2
     Else
        TheDate = TheDate - OddDays
     End If

     DateAddW = TheDate
   End If

End Function

'Private Sub Application_ItemSend(ByVal Item As Object, Cancel As
Boolean)End Sub'

Cheers,
Nick