[OUTLOOK][VBA]EMAIL自動下載附件

2013-11-21

16905
0
VBA
2014-05-12

在工作中，面對很多資料傳送是使用email傳送，由於面對十多家公司，

有些現在已沒有合作的公司，但持續需傳送最新的狀態，

本來正確的作法請所有的公司使用SFTP傳送，但本公司的防火牆又很兩光，採購又很繁索，

一切的一切變更不易的情況之下，只好採用沒有辦法中的辦法，只接從Email取下檔案，

原本是想找看看有沒有free的程式，可以使用，但有找到一個Mail Attachment Downloader，

看了一下內容，檔名會被變更(前面會加「寄件者的暱稱和 Email」)，

這下次原本預想請各公司改為某規則的檔案名稱(ex：檔名最前面加三碼的公司代碼)的想法無法實現，

最後一直拜G神，終於回應我的誠心，找到了「返回最初的純真性情 http://blog.udn.com/WayCheng/2711617」

他說OUTLOOK有VBA！！，也寫了下載附件的方法，這下子一切都有解了，

參考了他的code，並加入下載的檔案依Mail中的DNS分目錄，

但有一個缺點，我不知道如何讓它自動執行，與如何分辨已下載過的檔案(或Mail)，

於是又找到了「阿男的部落格 http://jonaschen.blogspot.tw/2009/07/outlook.html」，

上面有教說可以將所寫的VBA植入MSOUTLOOK規則中，

其中重點是傳入的參數必需為「Outlook.MailItem」，如此就可以在MSOUTLOOK規則可選取的到

讓MSOUTLOOK可以依每新進一封Mail執行此VBA並ReName主旨，

MSOUTLOOK規則又可將已處理過的Mail搬移至其它目錄，一切的一切都美好的起來。

下面是已修改完成的Code請參考。


Sub SaveAttachments(mail As Outlook.MailItem)  
''「mail As Outlook.MailItem」需要有此「簽章」MSOUTLOOK規則中 
''  會將收件匣所有附件檔另存

Dim myNameSpace As Outlook.NameSpace 
Dim myFolder As Outlook.MAPIFolder 
Dim myAttachments As Outlook.Attachments 
Dim myItems As Outlook.Items 
Dim TargetFolder As String, SFName As String, NSFName As String, myEmailAddress As String 
Dim i As Integer



TargetFolder = "D:\Email\Process"       '檔案將要存入此處

Set fs = CreateObject("Scripting.FileSystemObject") 
Set myNameSpace = Application.GetNamespace("MAPI") 
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox) 
'myFolder 代表 "收件匣 Inbox" 
Set myItems = myFolder.Items 
'myItems 代表 "收件匣" 中所有信件 (的集合)

''For Each mail In myItems    '檢查每一封信     ''原本是全部的Mail都處理，修改為交由MSOUTLOOK規則執行 
     myEmailAddress = mail.SenderEmailAddress 
     mymailArr = Split(myEmailAddress, "@") 
     myEmailAddressDns = mymailArr(1)             ''取得Mail中的DNS 
    Set myAttachments = mail.Attachments 
    ''myAttachments 代表這封信件裡所有附件檔 (的集合) 
    TargetFolderMail = TargetFolder & "\" & myEmailAddressDns 
    If Dir(TargetFolderMail, vbDirectory) = "" Then MkDir TargetFolderMail 
    If Mid(mail.Subject, 1, 9) <> "!!SAVED!!" Then   ''排除已處理Mail 
        For Each att In myAttachments ' 
            SFName = TargetFolderMail & "\" & att.FileName 
            If fs.FileExists(SFName) Then ''若檔案已存在, 就加上 (數字) 
                i = 0 
                Do 
                    NSFName = TargetFolderMail & "\" & fs.GetBaseName(SFName) _ 
                          & "(" & i & ")." & fs.GetExtensionName(SFName) 
                    i = i + 1 
                Loop While fs.FileExists(NSFName) 
                att.SaveAsFile NSFName ''用加了數字的檔名儲存 
            Else 
                att.SaveAsFile SFName  ''若檔案不存在, 就用原來的檔名儲存 
            End If 
        Next att 
        mail.Subject = "!!SAVED!!" + mail.Subject   ''已處理過的Mail將主旨前面加『文字』'' 
        mail.Save 
    End If 
''Next mail

End Sub

回首頁