Outlook: Saving attachments automatically

Add into outlook rules the following VBScripts:

Sub SaveToFolder(MyMail As MailItem)

Dim strID As String

Dim objNS As Outlook.NameSpace

Dim objMail As Outlook.MailItem

Dim objAtt As Outlook.Attachment

Dim c As Integer

Dim save_name As String

'Place path to sav to on next line. Note that you must include the

'final backslash

Const save_path As String = "X:\SHARE\VCMS CSV\CSV\"

StrID = MyMail.EntryID

Set objNS = Application.GetNamespace("MAPI")

Set objMail = objNS.GetItemFromID(strID)

If objMail.Attachments.Count > 0 Then

For c = 1 To objMail.Attachments.Count

Set objAtt = objMail.Attachments(c)

Save_name = Left(objAtt.FileName, Len(objAtt.FileName) - 4)

'save_name = save_name & Format(objMail.ReceivedTime, "_mm-dd-yyyy_hhmm")

Save_name = save_name & Right(objAtt.FileName, 4)

ObjAtt.SaveAsFile save_path & save_name

Next

End If

Set objAtt = Nothing

Set objMail = Nothing

Set objNS = Nothing

End Sub