Question

我想将所有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

Answer 1

代码效率极低，这是多点符号。在进入循环之前缓存Items集合并在每次迭代时仅检索一次项目 - 否则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

使用pr_last_verb_executed将所有邮件从收件箱中提取到Excel工作表中

1 个答案: