Save Outlook Attachments On Your Desktop

If you want to run a loop through all unread emails in your inbox or any specific folder and then save all attachments from each mail on to your desktop.Try this macro



Option Explicit
Sub sample_macro()
    'reference -> microsoft outlook
    Dim oitem As Outlook.MailItem
    Dim ol As Outlook.Application
    Dim olns As Outlook.Namespace
    Dim oinbox As Outlook.Folder
    Dim dpath As String, I As Long, j As Long
    
    dpath = "C:\Documents and Settings\user\My Documents\sample\" ' choose folder to save attachments
    
    ThisWorkbook.Sheets(1).Range("a2:d" & ThisWorkbook.Sheets(1).Range("a1048576").End(xlUp).Row + 1).Clear 'clear existing data if any
    
    Set ol = New Outlook.Application
    Set olns = ol.GetNamespace("MAPI")
    
    Set oinbox = olns.GetDefaultFolder(olFolderInbox) 'select the inbox
    Set oinbox = oinbox.Folders("DM") ' select if you wnat to choose any specific folder
    oinbox.Items.Sort "[ReceivedTime]", True
    j = 2
    
    For Each oitem In oinbox.Items
        For I = 1 To oitem.Attachments.Count
            ThisWorkbook.Sheets(1).Range("a" & j).Value = oitem.SenderName
            ThisWorkbook.Sheets(1).Range("b" & j).Value = oitem.Subject
            ThisWorkbook.Sheets(1).Range("c" & j).Value = oitem.ReceivedTime
            ThisWorkbook.Sheets(1).Range("d" & j).Value = oitem.Attachments.Item(I).DisplayName
            oitem.Attachments.Item(I).SaveAsFile dpath & oitem.Attachments.Item(I).DisplayName
            j = j + 1
        Next
    Next
    
    Set oinbox = Nothing
    Set olns = Nothing
    Set ol = Nothing
End Sub