Step-by-Step guide to download attachments from Outlook using VB Macro

1Option Explicit
2Sub SaveExcelAttachments_Simple()
3    Dim ns As Outlook.NameSpace
4    Dim st As Outlook.store
5    Dim root As Outlook.MAPIFolder
6    Dim f1 As Outlook.MAPIFolder
7    Dim f2 As Outlook.MAPIFolder
8    Dim itms As Outlook.items
9    Dim i As Long
10    Dim mail As Outlook.MailItem
11    Dim att As Outlook.Attachment
12    Dim saveFolder As String
13    Dim saved As Long, scanned As Long
14    ' ==== Settings (adjust if needed) ====
15    Const MAILBOX_NAME As String = ""
16    Const FOLDER_PATH As String = "<Sub>" ' under the mailbox root
17    saveFolder = "C:TempOutlookXlsx"
18    ' =====================================
19    Set ns = Application.GetNamespace("MAPI")
20    ' Find mailbox root
21    For Each st In ns.Stores
22        If StrComp(st.DisplayName, MAILBOX_NAME, vbTextCompare) = 0 Then
23            Set root = st.GetDefaultFolder(olFolderInbox).Parent
24            Exit For
25        End If
26    Next st
27    If root Is Nothing Then
28        MsgBox "Mailbox not found: " & MAILBOX_NAME, vbExclamation
29        Exit Sub
30    End If
31    ' Walk to the target folder 
32    Set f1 = Nothing: Set f2 = Nothing
33    On Error Resume Next
34    Set f1 = root.Folders("")
35    If Not f1 Is Nothing Then Set f2 = f1.Folders("")
36    On Error GoTo 0
37    If f2 Is Nothing Then
38        MsgBox "Folder not found: " & FOLDER_PATH, vbExclamation
39        Exit Sub
40    End If
41    ' Ensure save directory exists
42    CreateFolderIfMissing saveFolder
43    ' Get items and sort (newest first)
44    Set itms = f2.items
45    itms.Sort "[ReceivedTime]", True
46    ' Loop emails and save Excel attachments
47    For i = 1 To itms.count
48        If TypeOf itms(i) Is Outlook.MailItem Then
49            Set mail = itms(i)
50            scanned = scanned + 1
51            If mail.Attachments.count > 0 Then
52                For Each att In mail.Attachments
53                    If IsExcelAttachment(att.fileName) Then
54                        Dim ts As String
55                        Dim cleanAttach As String
56                        Dim targetPath As String
57                        ts = Format(mail.ReceivedTime, "yyyy-mm-dd_hhmmss")
58                        cleanAttach = SanitizeFileName(att.fileName)
59                        targetPath = EnsureUniquePath(saveFolder, ts & " - " & cleanAttach)
60                        att.SaveAsFile targetPath
61                        saved = saved + 1
62                    End If
63                Next att
64            End If
65        End If
66    Next i
67    MsgBox "Done!" & vbCrLf & _
68           "Folder: " & f2.folderPath & vbCrLf & _
69           "Emails scanned: " & scanned & vbCrLf & _
70           "Excel attachments saved: " & saved & vbCrLf & _
71           "Saved to: " & saveFolder, vbInformation
72End Sub
73' --- Helpers ---
74Private Function IsExcelAttachment(fileName As String) As Boolean
75    Dim ext As String
76    ext = LCase$(Mid$(fileName, InStrRev(fileName, ".") + 1))
77    Select Case ext
78        Case "xlsx", "xls", "xlsm", "xlsb", "csv"
79            IsExcelAttachment = True
80        Case Else
81            IsExcelAttachment = False
82    End Select
83End Function
84Private Function SanitizeFileName(ByVal s As String) As String
85    ' Remove characters invalid for Windows filenames
86    Dim badChars As Variant, ch As Variant
87    badChars = Array("", "/", ":", "*", "?", """", "", "|")
88    For Each ch In badChars
89        s = Replace$(s, ch, " ")
90    Next ch
91    ' Collapse double spaces
92    Do While InStr(s, "  ") > 0
93        s = Replace$(s, "  ", " ")
94    Loop
95    SanitizeFileName = Trim$(s)
96End Function
97Private Sub CreateFolderIfMissing(ByVal path As String)
98    If Len(Dir$(path, vbDirectory)) = 0 Then
99        MkDir path
100    End If
101End Sub
102Private Function EnsureUniquePath(ByVal folder As String, ByVal fileName As String) As String
103    ' If file exists, append (1), (2), ...
104    Dim base As String, ext As String, p As Long, candidate As String
105    Dim n As Long
106    p = InStrRev(fileName, ".")
107    If p > 0 Then
108        base = Left$(fileName, p - 1)
109        ext = Mid$(fileName, p)          ' includes dot
110    Else
111        base = fileName
112        ext = ""
113    End If
114    candidate = folder & "" & fileName
115    n = 1
116    Do While Len(Dir$(candidate)) > 0
117        candidate = folder & "" & base & " (" & n & ")" & ext
118        n = n + 1
119    Loop
120    EnsureUniquePath = candidate
121End Function