Sub SaveAttachments()

'會將收件匣中 "特定資料匣" 裡所有信件的附件檔全部另存到程式裡設定的路徑去

Dim myNameSpace As Outlook.NameSpace

Dim myFolder, myInbox As Outlook.MAPIFolder

Dim myAttachments As Outlook.Attachments

Dim myItems As Outlook.Items

Dim TargetFolder As String, SFName As String, NSFName As String

Dim MailDate As String '(1) 宣告一個字串來放 "寄件日期" 或 "收件日期"

Dim i As Integer

TargetFolder = "C:\測試區"       '檔案將要存入此處

Set fs = CreateObject("Scripting.FileSystemObject")

Set myNameSpace = Application.GetNamespace("MAPI")

Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)  'myFolder 代表 "收件匣 Inbox"                                        

Set myFolder = myInbox.Folders("XXX")    'XXX 是 "特定資料匣"，是在收件匣中

Set myItems = myFolder.Items    'myItems 代表 "特定資料匣" 中所有信件 (的集合)

For Each mail In myItems   '檢查每一封信

    '底下兩種用日期命名方法可以二選一

    MailDate = Year(mail.SentOn) & Month(mail.SentOn) & Day(mail.SentOn)

                       '(1)上面這一行是取得"寄件日期"，做成 YYYYMMDD 格式的字串

    'MailDate = Year(mail.ReceivedTime) & Month(mail.ReceivedTime) & Day(mail.ReceivedTime)

                       '(2)上面這一行是取得"收件日期"，做成 YYYYMMDD 格式的字串

    Set myAttachments = mail.Attachments     'myAttachments 代表這封信件裡所有附件檔 (的集合)

    For Each att In myAttachments

        SFName = TargetFolder & "\" & MailDate & "_" & att.DisplayName

                 '在檔名前面加上 寄件 (或收件) 日期的 YYYYMMDD 格式的字串

        If fs.FileExists(SFName) Then '若檔案已存在, 就加上 (數字)

            i = 0

            Do

                NSFName = TargetFolder & "\" & fs.GetBaseName(SFName) & "(" & i & ")." & s.GetExtensionName(SFName)

                i = i + 1

            Loop While fs.FileExists(NSFName)

            att.SaveAsFile NSFName '用加了數字的檔名儲存

        Else

            att.SaveAsFile SFName  ''若檔案不存在, 就用原來的檔名儲存

        End If

    Next att

Next mail

End Sub