網路城邦
上一篇 回創作列表 下一篇   字體:
將收件匣中 "特定資料匣" 裡所有信件的附件檔全部另存到指定的路徑去
2017/12/21 00:58:37瀏覽954|回應0|推薦0
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
( 知識學習考試升學 )
回應 推薦文章 列印 加入我的文摘
上一篇 回創作列表 下一篇

引用
引用網址:http://classic-blog.udn.com/article/trackback.jsp?uid=WayCheng&aid=109617543