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
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的信任中心勾选上“允许使用脚本”。
