Auto save attachments into a particular file directory.

[Shazam]

Hi everyone,


I have this particular user sends me an email attachment into my subfolder of my inbox and I manually save the attachment into a file directory. How would I get this automated? I found this code below and when I tested it out the attachment does not get save. Am I missing something?

http://www.vbaexpress.com/forum/showthread.php?t=26780&highlight=Auto+save+attachments

I put this macro in the Outlook session module.

I'm using Outlook 2007 SP2.


Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim mai As Object
Dim strEntryIDs() As String
Dim lngEntryIDIndx As Long
Dim ns As Outlook.NameSpace
Dim mlItm As Outlook.MailItem
Dim atchmnt As Outlook.Attachment
Set ns = Outlook.Session
'You can get several mail items at a time:
strEntryIDs = Split(EntryIDCollection, ",")
'Loop through mail items:
For lngEntryIDIndx = 0 To UBound(strEntryIDs)
Set mai = ns.GetItemFromID(strEntryIDs(lngEntryIDIndx))
'Not all entry ids will be for Mail Items:
If TypeOf mai Is Outlook.MailItem Then
'You don't have to convert to a Mail Item object, I just prefer to
'so I can use the intellisense.
Set mlItm = mai
If LCase$(mlItm.SenderEmailAddress) = "emailaddress@home.com" Then
For Each atchmnt In mlItm.Attachments
'This will overwrite without prompting, watch it:
atchmnt.SaveAsFile "C:\Test\" & atchmnt.FileName
Next
End If
End If
Next
End Sub

[Shazam]

Ok...

I found way of doing this. First I created a new module under "ThisOulookSession" and pasted this code into it. Then I created a new rule in the "Rules and Alert" function. So when a particular user emails me it will run a script (macro) in my Outlook VBA.

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 = "C:\Test\"

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