用VBA，把OUTLOOK 2010裏指定天數之前的郵件，轉移到另外的文件夾裏

　　同事提出了一個需求，說是老大交待的，要我幫助他。因爲OutLook沒有錄製宏的功能，沒做過的話那就是無從下手。所以在他傳遞過來的示例代碼的基礎上，我寫了如下VBA程序（用Alt+F11，在ThisOutLookSesson裏）：

Public blnSearchComp As Boolean

Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
blnSearchComp = True
End Sub

'把 PST 和 Folder 合二爲一，想多少層子目錄都行（前提是：要保證給出的子目錄參數，確實都是存在的）

Function MoveOldMail_A(cSourcePST_And_Folder As String, cDestPST_And_Folder As String, nDiffDays As Integer)
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace

Dim sch As Outlook.Search
Dim rsts As Outlook.Results
Dim i As Integer
Dim strTag As String
Dim objVariant As Variant
Dim objDestFolder As Outlook.MAPIFolder


Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")

On Error Resume Next

' 把傳遞過來的去向PST和FOLDER進行層層分解

aDest = Split(cDestPST_And_Folder, "\")
Select Case UBound(aDest, 1)
Case 0 ' 沒有斜槓，那就說明是根目錄
Set objDestFolder = objNamespace.Folders(cDestPST_And_Folder)
Case 1 '第一層子目錄
Set objDestFolder = objNamespace.Folders(aDest(0)).Folders(aDest(1))
Case 2 '第二層子目錄
Set objDestFolder = objNamespace.Folders(aDest(0)).Folders(aDest(1)).Folders(aDest(2))
Case 3 '第三層子目錄
Set objDestFolder = objNamespace.Folders(aDest(0)).Folders(aDest(1)).Folders(aDest(2)).Folders(aDest(3))
Case Else '以此類推，要加多少層都可以
End Select

blnSearchComp = False
strTag = "按指定日期搜索"

Dim cBeforeDate As String
cBeforeDate = Format(DateAdd("d", 0 - nDiffDays, Now), "YYYY.MM.DD 0:00")
Dim strF As String
strF = "urn:schemas:httpmail:datereceived <= '" & cBeforeDate & "'"

' 第三個參數如果是True，那麼就是遍歷子目錄。
Set sch = Application.AdvancedSearch(cSourcePST_And_Folder, strF, True, strTag)
While blnSearchComp = False
DoEvents
Wend

' 把找到的郵件，通通搬移到去向PST中
Set rsts = sch.Results
lnMoveMailCount = rsts.Count
For Each objResult In rsts
objResult.Move objDestFolder
Next

MsgBox "本次操作移動了： " & lnMoveMailCount & " 封郵件！"
Exit Function

IfHasError:
Select Case Err.Number ' 檢查錯誤代號。
Case -2147221233
cErrMsgInfo = MsgBox("找不到指定的PST文件！")
Case Else
' 以後不論發現多少種錯誤，就往裏面添加相對應的處理方式就行了
End Select
End Function

Public Sub Demo()
' 調用示例：把用戶指定PST下任意子文件夾內的郵件，凡超過40天的郵件，通通移動到一個名叫“OLD”的PST、“保存郵件”目錄內

Dim NeedDays As Integer
NeedDays = 0

On Error Resume Next
NeedDays = InputBox("請給出您想清理多少天之前的郵件", "默認是40天", 40)
If NeedDays <= 0 Then '用戶點擊了“取消”
Exit Sub
End If
NotQuit = 1

' 注意：第一個參數，除了雙引號以外，還要單引號！
' 而第二個參數，前面不用再加斜槓，前後也不用加單引號！
ToDo = MoveOldMail_A("'\[email protected]\收件匣'", "Old\保存郵件", NeedDays)
End Sub