Attachments to a Folder Save

[jamesexcel1970]

Hello

Am using outlook 2016 and looking forward to save all attachments to a particular folder in my system..tried but no luck.

 

[Monty]

Hello James.

Done recently this exercise at work.
Working fine for me, let me know any changes required!

Sub Save_attatchments()

'Step 1:  Declare your variables
    Dim ns As Namespace
    Dim MyInbox As MAPIFolder
    Dim MItem As MailItem
    Dim Atmt As Attachment
    Dim FileName As String
'Step 2:  Set a reference to your inbox
    Set ns = GetNamespace("MAPI")
    Set MyInbox = ns.GetDefaultFolder(olFolderInbox)
   
   
'Step 3:  Check for messages in your inbox; exit if none
    If MyInbox.Items.Count = 0 Then
    MsgBox "No messages in folder."
    Exit Sub
    End If


'Step 4:  Create directory to hold attachments
    On Error Resume Next
    MkDir "C:\Moty\"
     

'Step 5:  Start to loop through each mail item
    For Each MItem In MyInbox.Items
   

'Step 6:  Save each attachement then go to the next attachment
    For Each Atmt In MItem.Attachments
    FileName = "C:\Moty\" & Atmt.FileName
    Atmt.SaveAsFile FileName
    Next Atmt
   
'Step 7:  Move to the next mail item
    Next MItem
   
'Step 8:  Memory cleanup
    Set ns = Nothing
    Set MyInbox = Nothing
   
   
End Sub

 

[jamesexcel1970]

Will try at work.

Can me do me a favor..if i wanted to save certain attachments only as we receive 100+ attachment with the same subject.

So wanted to have two macro's.

Hope this make sense else please advise.

 

[Monty]

Sub Save_Particular_attatchment()

'Step 1:  Declare your variables
    Dim ns As Namespace
    Dim MyInbox As MAPIFolder
    Dim MItem As Object
    Dim Atmt As Attachment
    Dim FileName As String
    Dim i As Integer
   
'Step 2:  Set a reference to your inbox
    Set ns = GetNamespace("MAPI")
    Set MyInbox = ns.GetDefaultFolder(olFolderInbox)
   
'Step 3:  Check for messages in your inbox; exit if none
    If MyInbox.Items.Count = 0 Then
    MsgBox "No messages in folder."
    Exit Sub
    End If

'Step 4:  Create directory to hold attachments
    On Error Resume Next
    MkDir "C:\Monty\"
   
'Step 5:  Start to loop through each mail item
    For Each MItem In MyInbox.Items
   
'Step 6:  Check for the words Data Submission in Subject line
    If InStr(1, MItem.Subject, "Monty") < 1 Then  'Change "Monty" to your subject which you are looking for
    GoTo SkipIt
    End If

'Step 7:  Save each with a log number; go to the next attachment
    i = 0
    For Each Atmt In MItem.Attachments
    FileName = _
    "C:\Monty\Attachment-" & i & "-" & Atmt.FileName
    Atmt.SaveAsFile FileName
    i = i + 1
    Next Atmt
   
'Step 8:  Move to the next mail item
SkipIt:
    Next MItem
     
'Step 9:  Memory cleanup
    Set ns = Nothing
    Set MyInbox = Nothing
   
   
End Sub

Try this..

 

[jamesexcel1970]

Thank you champ!

 

[kenneth]

Thank you Champ. Can you adjust the code enabling saving attachments only from selected e-mails? That will be more helpful.