[RESOLVED] Outlook 2007 - How to save Email Attachments to Local Disc

Hi All,

I want to save the attachments of Email (Sent with a particular Subject Line), to my local machine. Can someone please tell me the way to do this.

My attachment may contain any type of file.

Regards,
Mr.Cool

Welcome to the forums :wave:

Here are few links to achieve what you want. Understand the code and then amend it as per your needs. If you get stuck, simply post the code that you tried and we will definitely help you :)

http://www.vbaexpress.com/kb/getarticle.php?kb_id=522
http://www.outlookcode.com/codedetail.aspx?id=70
http://www.outlookcode.com/codedetail.aspx?id=1494
http://www.outlook-tips.net/code/saveatt.htm

Thanks SID.

I will try that.

Okey, I stuck once again.

I used following code which is saving attachments for selected records:

vb Code:

Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String
 
    strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16)
    Set objOL = CreateObject("Outlook.Application")
    Set objSelection = objOL.ActiveExplorer.Selection
    strFolderpath = strFolderpath & "\OLAttachments\"
    MsgBox strFolderpath
    For Each objMsg In objSelection
    Set objAttachments = objMsg.Attachments
    lngCount = objAttachments.Count
       If lngCount > 0 Then
       For i = lngCount To 1 Step -1
    strFile = objAttachments.Item(i).FileName
        strFile = strFolderpath & strFile
        objAttachments.Item(i).SaveAsFile strFile
     
    If objMsg.BodyFormat <> olFormatHTML Then
        strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">"
        Else
        strDeletedFiles = strDeletedFiles & "<br>" & "<a href='file://" & _
        strFile & "'>" & strFile & "</a>"
    End If
        MsgBox strDeletedFiles
        Next i
    End If
        If objMsg.BodyFormat <> olFormatHTML Then
        objMsg.Body = objMsg.Body & vbCrLf & _
        "The file(s) were saved to " & strDeletedFiles
    Else
        objMsg.HTMLBody = objMsg.HTMLBody & "<p>" & _
        "The file(s) were saved to " & strDeletedFiles & "</p>"
    End If
        objMsg.Save
    ' End If
    Next
    ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub

To run this rule automatically, I want to create a rule which says

If a msg. comes with specific subject Move this to Some Folder and run the script

The problem is that when it is showing no script names in Select Script Box.

Please Note: I copied the code under ThisOutlookSession (Pressing Ctrl+F11 on Outlook and pasted the code on VBA window)

How can I modify my script so that it will run on the Mails with specific subject and also how can I select the script name while creating the rule?

:ehh:Still No luck :confused:

Can some one please look into this :confused:

Use the The NewMailEx event which fires for messages arriving on any email account.

In the NewMailEx event, check for the "specific subject" and if found, call the sub that you have written. The event is in the built-in ThisOutlookSession module in Outlook VBA.

Hope this helps...

Hi Sid,

Thanks for your reply.

I made some changes in my script and now it is working fine.

But the problem is I am not able to create a following Rule:

If Subject Contains OLAttach move it to folder OutlookAttach and Run Script

When I am trying to set Script name - It is not showing even a single script to select in "Select Script" box.

How can I get my script name displaying here????

Show me the code that you are using to check the subject?

I am just applying a rule that If subject contains word OlAttachment then move the message to OutlookAttachment Folder (which is the subfolder of Inbox)

After this I am just trying to run macro on the contents of OutlookAttachment folder only.

Here is the code which I am using right now

Code:

---

Sub GetAttachments()
 
 On Error GoTo GetAttachments_err
 
 Dim ns As NameSpace
 Dim Inbox As MAPIFolder
 Dim SubFolder As MAPIFolder
 Dim Item As Object
 Dim Atmt As Attachment
 Dim FileName As String
 Dim i As Integer
 
 
 Set ns = GetNamespace("MAPI")
 Set Inbox = ns.GetDefaultFolder(olFolderInbox)
 Set SubFolder = Inbox.Folders("AutomationOutlook")
 i = 0
 
 
 
 If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the Inbox.", vbInformation, _
          "Nothing Found"
    Exit Sub
 End If
 
 For Each Item In SubFolder.Items
    For Each Atmt In Item.Attachments
      FileName = "C:\OutlookAttachments\" & Atmt.FileName
      Atmt.SaveAsFile FileName
      i = i + 1
    Next Atmt
 Next Item
 
 If i > 0 Then
    MsgBox "I found " & i & " attached files." _
      & vbCrLf & "I have saved them into the C:\OutlookAttachments folder." _
      & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
 Else
    MsgBox "I didn't find any attached files in your mail.", vbInformation, _
    "Finished!"
End If
 
GetAttachments_exit:
  Set Atmt = Nothing
  Set Item = Nothing
  Set ns = Nothing
  Exit Sub
 
GetAttachments_err:
  MsgBox "An unexpected error has occurred." _
      & vbCrLf & "Please note and report the following information." _
      & vbCrLf & "Macro Name: GetAttachments" _
      & vbCrLf & "Error Number: " & Err.Number _
      & vbCrLf & "Error Description: " & Err.Description _
      , vbCritical, "Error!"
  Resume GetAttachments_exit
 
End Sub
 
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
 
End Sub

---

But I am unable to run this script automatically. I want to run macro automatically as soon as the new mail arrive.

Do this...

First paste your macro in the module.

Then

Click on Tools~~>Rules and Alerts
Click on "New Rule"
Click on "start from a blank rule"
Select "Check messages When they arrive"
Under conditions, click on "with specific words in the subject"
Click on "specific words" under rules description.
Type the word that you want to check in the dialog box that pops up and click on "add".
Click "Ok" and click next
select "move it to specified folder" and also select "run a script" in the same box
In the box below, specify the specific folder and also the script (the macro that you have in module) to run.
Click on finish.

You are done :)

I performed the exact steps you mentioned but in the last step when I clicked on script link (To add the script which I want to run), it opens a select script box, but this box is empty i.e. it is not diplaying any script name to select.

What should I do so that it will display my script name (Or macro name) in select script box?

Paste the macro in a module and not in the ThisOutlookSession ;)

To get the module, right click on the ThisOutlookSession and click on "Insert module"

Tried that but all efforts gone in vain.

Still I am not able to see script Name in select script Box.

SID Is their any other way to run this script automatically?

I would appreciate if someone will help me in troubleshooting this Select Script Problem.

Show me a screenshot of

1) the place where you have pasted the script.
2) the window where u need to select the script.

Please Find the Screenshot enclosed with this mail as an attachments

A "run a script" rule action takes a MailItem or MeetingItem as its parameter, then uses that item in the code:

Change your code to

Code:

---

Sub GetAttachments(MyMail As MailItem)
    '~~> Your relevant code
End Sub

---

Also click on Tools~~>Macro~~>Security and set it to low for your macro to work....

SID u Rocks Man.

Problem is solved now.

But I got one another Problem now:

My script is running before my mail comes to destination Folder (OutlookAutomation Folder).

In this case I am facing following problems:

1. If OutlookAutomation Folder is empty then It is saving No attachments (As script is running before the new mail arrives in this Folder).

2. If already there are few mail attachments present in this folder, then it is saving attachments of old mails - but I want it to save attachment of latest arrived mail.

Show me the final code that you are using.... we might need to add few conditions in that...

Here is the final code I am using.

vb Code:

Sub GetAttachments(MyMail As MailItem)
 
 On Error GoTo GetAttachments_err
 
 Dim ns As NameSpace
 Dim Inbox As MAPIFolder
 Dim SubFolder As MAPIFolder
 Dim Item As Object
 Dim Atmt As Attachment
 Dim FileName As String
 Dim i As Integer
 
 
 Set ns = GetNamespace("MAPI")
 Set Inbox = ns.GetDefaultFolder(olFolderInbox)
 Set SubFolder = Inbox.Folders("AutomationOutlook")
 i = 0
 
 
 
 If SubFolder.Items.Count = 0 Then
    MsgBox "There are no messages in the Inbox.", vbInformation, _
           "Nothing Found"
    Exit Sub
 End If
 
 
 For Each Item In SubFolder.Items
    For Each Atmt In Item.Attachments
       FileName = "C:\OutlookAttachments\" & Atmt.FileName
       Atmt.SaveAsFile FileName
       i = i + 1
    Next Atmt
 Next Item
 
 If i > 0 Then
    MsgBox "I found " & i & " attached files." _
       & vbCrLf & "I have saved them into the C:\OutlookAttachments folder." _
       & vbCrLf & vbCrLf & "Have a nice day.", vbInformation, "Finished!"
 Else
    MsgBox "I didn't find any attached files in your mail.", vbInformation, _
    "Finished!"
    
End If
 
GetAttachments_exit:
   Set Atmt = Nothing
   Set Item = Nothing
   Set ns = Nothing
   Exit Sub
   
GetAttachments_err:
   MsgBox "An unexpected error has occurred." _
      & vbCrLf & "Please note and report the following information." _
      & vbCrLf & "Macro Name: GetAttachments" _
      & vbCrLf & "Error Number: " & Err.Number _
      & vbCrLf & "Error Description: " & Err.Description _
      , vbCritical, "Error!"
   Resume GetAttachments_exit
 
End Sub

Check this for me....

Paste this code and set the script to "Sample". Now send yourself a sample email with the relevant subject... does it run before you receive the email or after you receive it.

Code:

---

Sub Sample(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
   
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
   
    '~~> Display the subject
    MsgBox olMail.Subject
   
    Set olMail = Nothing
    Set olNS = Nothing
End Sub

---

Also this

Quote:

---

For Each Item In SubFolder.Items

---

is causing the code to run for all emails...

Edit: In the meantime I will amend your code...

How to test this?

This script is not saving any attachments.

So I am unable to decide whether script is running before the mail arrives in the destination folder or after that.

It won't save the attachment, it will display a message.... The subject of the email... This is a test code.... If this works then I can give you a more refined code...

Anyways... you can still try this code... It's just that I don't have access to Outlook 2007.

Code:

---

Sub Sample(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
 
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
   
    If olMail.Attachments.Count > 0 Then
        '~~> Save the Attachement to the relevant path
        olMail.Attachments.Item.SaveAsFile "C:\OutlookAttachments\"
    Else
        '~~> Else inform the user
        MsgBox "No Atachments Found"
    End If
   
    Set olMail = Nothing
    Set olNS = Nothing
End Sub

---

Code is throwing compilation error at following Line :

Code:

---

olMail.Attachments.Item.SaveAsFile "C:\OutlookAttachments\"

---

Error shown is as follows:

Compile Error: Argument Not Optional

Since I cannot test it, test this for me...

Code:

---

Sub Sample(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
 
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
   
    If olMail.Attachments.Count > 0 Then
        For i = 1 To olMail.Attachments.Count
            '~~> Save all the Attachement to the relevant path
            olMail.Attachments.Item(i).SaveAsFile "C:\OutlookAttachments\"
        Next
    Else
        '~~> Else inform the user
        MsgBox "No Atachments Found"
    End If
   
    Set olMail = Nothing
    Set olNS = Nothing
End Sub

---

Thanks SID for your time.

SID I already tried that.

It is displaying Path error as follows:

Cannot save the attachment. Path does not Exist. Verify the Path is correct.

I tested by setting other path also, but still showing the same error.

Try removing the last backslash \ in the path...

Or better still try this...

Code:

---

Sub Sample(MyMail As MailItem)
    Dim strID As String, olNS As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim strFileName As String
   
    strID = MyMail.EntryID
    Set olNS = Application.GetNamespace("MAPI")
    Set olMail = olNS.GetItemFromID(strID)
   
    If olMail.Attachments.Count > 0 Then
        For i = 1 To olMail.Attachments.Count
            strFileName = "C:\OutlookAttachments\" & olMail.Attachments.Item(i).FileName
            '~~> Save all the Attachement to the relevant path
            olMail.Attachments.Item(i).SaveAsFile strFileName
        Next
    Else
        '~~> Else inform the user
        MsgBox "No Atachments Found"
    End If
   
    Set olMail = Nothing
    Set olNS = Nothing
End Sub

---

Thanks SID.

It looks like It is working exactly the way I want it to work.

Thanks for your help and time.

Glad to be of help :)

Do remember to mark the thread resolved by pulling down the threads menu on the top and clicking on "Mark Thread Resolved" ;)

Thanks SID

But I've abother problem is:

If I applied with more than 1 rule, the other rules' attachments cannot be automatically saved!!!

What I've done is different rule with different module, and the only difference between modules is different save path~

I dunno why~ can you help me to check???

Welcome to the forums :wave:

I will be glad to help you. Just request a mod to split your thread from this thread and make it an independent thread. I hardly go back in 'Resolved' threads. It was sheer luck that I saw your post :)

<~~~~ You can use the exclamation icon in a triangle on the left hand side down below to request a mod ;)