同事提出了一个需求，说是老大交待的，要我帮助他。因为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("'\ABC@XYZ.NET\收件匣'", "Old\保存邮件", NeedDays)
End Sub
可以把这个名叫“Demo”的过程，放到功能区里面作按钮。步骤是：
在OutLook的Ribbon中任意位置按鼠标右键，选择“自定义功能区”。然后点击右下角的“新建选项卡”按钮，命名“AAA”。再点击“新建组”。
再从左侧“从下列位置选择命令”，下拉列表框中选择宏，然后点击“Project1.ThisOutlookSession...”，点击中间的“添加按钮”。然后点击确定退出。回到前台，界面如下：
