Saving each send mail as MSG

I need to archive each mail via specific account each time its received or send. For received mail i use this script:

Public Sub SaveMsgInbox(Item As Outlook.MailItem)
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim enviro As String
 
  enviro = CStr(Environ("USERPROFILE"))
   
  sName = Item.Subject
  ReplaceCharsForFileName sName, "_"
 
  dtDate = Item.ReceivedTime
  sName = sName & ".msg"

   sPath = "Y:\mail_arhiva\msg_arhiva\Inbox\"
  Debug.Print sPath & sName
  Item.SaveAs sPath & sName, olMSG
End Sub
 
Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Select allOpen in new window

However, I cant make outlook 2010 run a script when i send mail. Otherwise i would use same script just different save path.

Edit: Code put into a snippet box. Graham Skan