1.需求：

在使用Outlook收发邮件时，有一些关键的邮件必须要进行答复或转发处理，为了防止遗漏，如何获取指定文件夹下的邮件处理信息呢？

2.思路：

对于已处理的邮件，即已回复或已转发的邮件，程序运行后，移至当前目录的子文件，命名为已处理完成，剩下的就是未处理的邮件，将未处理的邮件信息写入到指定的表格中，获取邮件主题，邮件接收时间。

3.示例：

信息源邮件目录：mymail\收件箱\测试

处理完成移动邮件目录：mymail\收件箱\测试\测试完成

信息源邮件目录.png

测试邮件：

测试邮件.png

4.方法

说明：因为需要获取Outlook邮件的非公开信息，即邮件最后一次的执行状态，需要引用到 PropertyAccessor，

所以使用VBA来解决此问题。

Invoke_VBA.png

VBA代码：

Sub get_outlook_info()
       Dim oMail, oPA As Object
       Dim PropName As String
       Dim Last_verb_executed As Long
       Dim i, j As Integer
       Dim my_outlook As Object
       Set my_outlook = CreateObject("outlook.application") '创建outlook应用对象
       Dim mailinfo As Object
       Set mailinfo = my_outlook.getnamespace("MAPI")   '获取outlook对象的命名空间
       Dim my_Subject, my_Recieve_time

       '定义获取信息源outlook文件夹，测试邮箱目录：mymail\收件箱\测试
       Dim objfolder As Object
       Set objfolder = mailinfo.Folders("mymail@mailaddress").Folders("收件箱").Folders("测试")

       '定义处理完成移动邮件文件夹    测试邮箱目录：mymail\收件箱\测试\测试完成
       Dim objfolder_move As Object
       Set objfolder_move = objfolder.Folders("测试完成")

       i = objfolder.Items.Count

       Dim row_in  '定义写入行号
       row_in = 2

       Range("A:D").Clear    '清空当前Excel A:D列数据
       '表头内容写入
       Cells(1, 1) = "序号"
       Cells(1, 2) = "邮件主题"
       Cells(1, 3) = "接收时间"
       Cells(1, 4) = "邮件操作返回值"

       For j = i To 1 Step -1
           Set oMail = objfolder.Items(j)
           '获取邮件主题
           my_Subject = oMail.Subject

           '获取邮件接收时间
           my_Recieve_time = oMail.creationtime

           '获取邮件最新的执行动作：
           '返回值0，未处理；
           '返回值102：不带附件回复;
           '返回值103：带附件回复；
           '返回值104：转发
           PropName = "http://schemas.microsoft.com/mapi/proptag/0x10810003"
           Set oPA = oMail.PropertyAccessor 
           Last_verb_executed = oPA.GetProperty(PropName) 

           If Last_verb_executed = 0 Then
               Cells(row_in, 1) = row_in - 1
               Cells(row_in, 2) = my_Subject
               Cells(row_in, 3) = my_Recieve_time
               Cells(row_in, 4) = Last_verb_executed
               row_in = row_in + 1
           Else
               oMail.Move objfolder_move
           End If

           Set oMail = Nothing
           Set oPA = Nothing
       Next j
       Set objfolder = Nothing
       Set objfolder_move = Nothing
       Set mailinfo = Nothing
       Set my_outlook = Nothing

       '修改所有Sheet的单元格列宽
       Dim iSheet As Integer
       For iSheet = 1 To Sheets.Count Step 1
           'A-D列单元格列宽自适应
           Sheets(iSheet).Range("A:D").EntireColumn.AutoFit
       Next iSheet
End Sub

5.执行结果：

测试文件夹：

测试文件夹.png

测试完成文件夹：

测试完成文件夹.png

记录表：

执行结果记录表.png