Извличане на всички писма от входящата кутия с pr_last_verb_executed в Excel - vba, excel-vba, email, outlook, outlook-vba

Искам да донеса всички имейли във входящата пощенска кутия на 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

Отговори:

Кодът е изключително неефективен, това е такамноготочкова нотация, взета до крайност. Съхранявайте кеш елементите, преди да влезете в цикъла и извлечете елемента само веднъж за всяка итерация - в противен случай OOM ще трябва да върне нов COM обект за всеки ".".

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