利用VBA將Outlook郵件的信息存入數據庫，批量下載附件並重命名

1.打開OutLook，用ALT+F11打開VBA編輯器

2.插入以下代碼：

Private Sub Application_NewMail()

     Dim myOlApp As Application
     Dim myNameSpace As NameSpace
     Dim myibox As MAPIFolder
     Dim mydelitems As MAPIFolder
     Dim myitem As MailItem
     Dim subject As String
     Dim rectime As String
     Dim from_addr As String
     Dim to_addr As String
     Dim emailbody As String
     Dim att_count As Integer
     Dim sql_str As String
     Dim strConn As String
     Dim myGuid As String
     Dim TypeLib
     Dim i As Integer
     Dim path As String

     Dim cn As Object
     Set cn = CreateObject("ADODB.Connection")
     strConn = "Provider=sqloledb;Server=192.168.3.9;Database=GEARMAGE;Uid=GEARMAGE;Pwd=GEARMAGE;"
     cn.Open strConn
     
     Set myOlApp = CreateObject("Outlook.Application")
     Set myNameSpace = myOlApp.GetNamespace("MAPI")
     Set myibox = myNameSpace.GetDefaultFolder(olFolderInbox)
     Set myFolder = myibox.Folders("PendingProcess")
     Set mymovefolder = myibox.Folders("Processed")
     Set TypeLib = CreateObject("Scriptlet.TypeLib")
     sql_str = String(3000, 0)
 
     For n = 1 To myFolder.Items.count
         Set myitem = myFolder.Items(n)
         If myitem.UnRead = True Then
            subject = myitem.subject
            rectime = myitem.CreationTime
            from_addr = myitem.SenderName
            to_addr = myitem.To
            emailbody = myitem.Body
            att_count = myitem.Attachments.count
            myGuid = Mid(TypeLib.GUID, 2, 36)
            sql_str = "INSERT INTO dbo.OUTLOOK_VBA_TEST( ID ,NAME ,EMAIL_DATE ,FROM_ADDR ,TO_ADDRS ,EMAIL_BODY ,ATTACHMENTS_COUNT) VALUES  ('" + myGuid + "','" + subject + "','" + rectime + "','" + from_addr + "','" + to_addr + "','" + emailbody + "'," + CStr(att_count) + ")"
            cn.Execute (sql_str)
            
            If att_count > 0 Then
             For i = 1 To att_count
              Set olAtt = myitem.Attachments(i)
                path = "D:\Email Attachment Temp\{" + myGuid + "}" + olAtt.FileName
               olAtt.SaveAsFile path
             Next
            End If
        End If
        myitem.Move mymovefolder
     Next n
     
     cn.Close
     Set cn = Nothing
     Set fldFolder = Nothing
     Set myNameSpace = Nothing


End Sub

　　3.利用Office Outlook 2007的規則，它可以設定對滿足一定條件的郵件自動運行腳本，然后選擇腳本為SaveAttach函數即可。這樣便能實現收到某些郵件時自動保存符合條件的附件到相應文件目錄。  說明：Outlook里面可以設置“通知和規則”，（在“工具”=>“規則和通知”）如圖：

注：在Outlook的信任中心勾選上“允許使用腳本在Outlook的信任中心勾選上“允許使用腳本”。