从收件箱中取出所有邮件，并将pr_last_verb_执行到Excel工作表中

我想将所有Outlook收件箱电子邮件提取到Excel工作表中，该工作表中的其他列包含数据，如此邮件在回复或此邮件转发到

这是我到目前为止已经完成的代码

Dim Folder As Outlook.MAPIFolder
Dim iRow As Integer
MailBoxName = 'Mailbox Name Goes Here
Pst_Folder_Name = "Inbox"
Set Folder = Outlook.Session.PickFolder 'Folders(MailBoxName).Folders(Pst_Folder_Name)      
If Folder = "" Then
    MsgBox "Invalid Data in Input"
    GoTo end_lbl1:
End If

Folder.Items.Sort "[ReceivedTime]", False
LimitDateTimeValue = 'Date Limit
CellNo = 2
For iRow = 1 To Folder.Items.Count
On Error Resume Next  
If Folder.Items.Item(iRow).ReceivedTime > LimitDateTimeValue Then
    'CellNo = 2
    On Error Resume Next
    ThisWorkbook.Sheets("Inbox").Range("A2").Select

    FullSubjectLine = Folder.Items.Item(iRow).Subject
    If InStr(1, FullSubjectLine, "FE:", vbTextCompare) > 0 Or InStr(1, FullSubjectLine, "FW:", vbTextCompare) > 0 Or InStr(1, FullSubjectLine, "RE:", vbTextCompare) Then
        FilteredSubjectLine = Mid(FullSubjectLine, 5)
        ThisWorkbook.Sheets("Inbox").Cells(CellNo, 2) = FilteredSubjectLine
    Else
        ThisWorkbook.Sheets("Inbox").Cells(CellNo, 2) = Folder.Items.Item(iRow).Subject
    End If

    ThisWorkbook.Sheets("Inbox").Cells(CellNo, 4) = Left(Folder.Items.Item(iRow).Body, 1024)
    If Folder.Items.Item(iRow).UnRead Then

        ThisWorkbook.Sheets("Inbox").Cells(CellNo, 6) = "UnRead"
    Else
        ThisWorkbook.Sheets("Inbox").Cells(CellNo, 6) = "Read"
    End If
        ThisWorkbook.Sheets("Inbox").Cells(CellNo, 1) = Folder.Items.Item(iRow).SenderName
    ThisWorkbook.Sheets("Inbox").Cells(CellNo, 3) = Folder.Items.Item(iRow).ReceivedTime

    CellNo = CellNo + 1

End If

Next iRow

---

代码效率极低，这是多点表示法的极限。在进入循环之前缓存Items集合，并在每次迭代中仅检索一次项-否则OOM将必须为每个“”返回一个全新的COM对象

出错时继续下一步
设置vItems=Folder.Items
对于iRow=1到vItems.Count
设置vItem=vItems.Item（iRow）
FullSubjectLine=vItem.Subject
lastVerbExecuted=vItem.PropertyAccessor.GetProperty（“http://schemas.microsoft.com/mapi/proptag/0x10810003")
如果错误号为0，则
lastVerbExecuted=0
呃，明白了
如果结束
...
下一个

代码效率极低，这是一种极端的多点表示法。在进入循环之前缓存Items集合，并在每次迭代中仅检索一次项-否则OOM将必须为每个“”返回一个全新的COM对象

出错时继续下一步
设置vItems=Folder.Items
对于iRow=1到vItems.Count
设置vItem=vItems.Item（iRow）
FullSubjectLine=vItem.Subject
lastVerbExecuted=vItem.PropertyAccessor.GetProperty（“http://schemas.microsoft.com/mapi/proptag/0x10810003")
如果错误号为0，则
lastVerbExecuted=0
呃，明白了
如果结束
...
下一个

我建议你看看XD编辑：我很好奇，如果人们喜欢这种方法，陌生人会要求他们的电脑/汽车/鞋子通过限定来修复，因为我是新的/不知道XDmore到了@findwindow提到你的地方，请根据这些指导原则更新您的帖子，以从本网站获得有意义的帮助。请显示您现有的代码。这些信息来自哪里？选择？一些文件夹？我的回答可能会让你开始。它会创建一个Excel工作簿，并将收件箱中每封电子邮件的选定属性复制到工作表中。感谢您发布代码，现在编辑您的问题，告诉我们它在哪里工作不正常，或者您在哪里卡住了。没有多少人会在没有任何指导的情况下尝试为您解决问题。我可以建议您看看XD Edit：我很好奇，如果有人喜欢这种方法，陌生人会不会要求他们的电脑/汽车/鞋子通过鉴定它来修复，因为我是新的/不知道XDmore到了@findwindow提到您的地方，请根据这些指导原则更新您的帖子，以从本网站获得有意义的帮助。请显示您现有的代码。这些信息来自哪里？选择？一些文件夹？我的回答可能会让你开始。它会创建一个Excel工作簿，并将收件箱中每封电子邮件的选定属性复制到工作表中。感谢您发布代码，现在编辑您的问题，告诉我们它在哪里工作不正常，或者您在哪里卡住了。没有多少人会在没有任何指导的情况下尝试为您解决此问题谢谢您的回复，但每次提交的lastVerbExecuted都返回0。我希望邮件显示“您于2015年10月27日下午5:52回复了此邮件”或“您于2015年10月27日下午5:52转发了此邮件”。在每封邮件前面，您是否确实看到邮件本身上的PR_LAST_VERB_EXECUTED和PR_LAST_VERB_EXECUTION_TIME属性？使用OutlookSpy查看消息（单击IMessage）。Outlook显示的字符串是根据这两个属性动态创建的。感谢您的回复，但每次更新中执行的lastVerbExecuted返回0。我希望邮件显示“您于2015年10月27日下午5:52回复了此邮件”或“您于2015年10月27日下午5:52转发了此邮件”。在每封邮件前面，您是否确实看到邮件本身上的PR_LAST_VERB_EXECUTED和PR_LAST_VERB_EXECUTION_TIME属性？使用OutlookSpy查看消息（单击IMessage）。Outlook显示的字符串是根据这两个属性动态创建的。

On Error Resume Next 
set vItems = Folder.Items
For iRow = 1 To vItems.Count
  set vItem = vItems.Item(iRow)
  FullSubjectLine = vItem.Subject
  lastVerbExecuted = vItem.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x10810003")
  if Err.Number <> 0 Then
    lastVerbExecuted = 0
    Err.Clear
  End If
  ...
next