Populate emails from Inbox to a listbox faster way - sql

Question

I have the following scenario. Populate a listbox1 with emails from InBox. I am using the
followings approach (Loop'For Each' and Sql '1 to count'):
LOOP
Sub Example_LOOP()
Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Dim Item As Object
Dim textDisplay As String
Dim resultReceived As String
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
For Each Item In olFolder.Items
If TypeOf Item Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = Item
textDisplay = oMail.Sender & " | " & oMail.Subject & " | " & oMail.ReceivedTime
resultReceived = textDisplay & "§" & resultReceived
End If
Next
With Me.ListBox1
.Clear
.List = Split(resultReceived, "§")
.RemoveItem (Me.ListBox1.ListCount - 1)
End With
End Sub
and SQL:
Public Sub Example_SQL()
Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder: Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim Items As Outlook.Items
Dim Item As Object
Dim i As Long
Dim Filter As String
Dim textDisplay As String
Dim resultReceived As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:fromname" & _
Chr(34) & "Like ''"
Set Items = olFolder.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", 1
For i = Items.Count To 1 Step -1
If TypeOf Items(i) Is MailItem Then
Set Item = Items(i)
textDisplay = Item.Sender & " | " & Item.Subject & " | " & Item.ReceivedTime
resultReceived = textDisplay & "§" & resultReceived
End If
Next
With Me.ListBox1
.Clear
.List = Split(resultReceived, "§")
.RemoveItem (Me.ListBox1.ListCount - 1)
End With
End Sub
Reading 10000 emails takes around 45 seconds. It is possibility to do it faster. Or maybe a different approach?
Thank you.

Answer 1

You can use Tables from the Outlook object model where you can specify only properties you are interested in. So, instead of loading in the loop each item from a folder you may iterate over rows in a table which I think can be much faster.
The Folder.GetTable method obtains a Table object that contains items filtered by Filter. By default, TableContents is olUserItems and the returned Table contains only the filtered items that are not hidden. If Filter is a blank string or the Filter parameter is omitted, GetTable returns a Table with rows representing all the items in the Folder.
GetTable returns a Table with the default column set for the folder type of the parent Folder. To modify the default column set, use the Add, Remove, or RemoveAll methods of the Columns collection object. You can use Table.Restrict to apply subsequent filters to a Table that is based on the Folder object. For example:
Sub DemoTable()
'Declarations
Dim Filter As String
Dim oRow As Outlook.Row
Dim oTable As Outlook.Table
Dim oFolder As Outlook.Folder
'Get a Folder object for the Inbox
Set oFolder = Application.Session.GetDefaultFolder(olFolderInbox)
'Define Filter to obtain items last modified after May 1, 2021
Filter = "[LastModificationTime] > '5/1/2021'"
'Restrict with Filter
Set oTable = oFolder.GetTable(Filter)
'Enumerate the table using test for EndOfTable
Do Until (oTable.EndOfTable)
Set oRow = oTable.GetNextRow()
Debug.Print (oRow("Subject"))
Debug.Print (oRow("LastModificationTime"))
Loop
End Sub`

Answer 2

In addition to Eugene's suggestion, do not load all items. Load them on demand as the user scrolls through the list.

Answer 3

I have done it like this, and it is working fine (I can add only the properties that I'm looking for). Thanks to show me the direction. :)
Public Sub ExtractInBoxInfo()
Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim oFolder As Outlook.MAPIFolder: Set oFolder = objNS.GetDefaultFolder(olFolderInbox)
Dim oTable As Outlook.Table
Dim oRow As Outlook.Row
Dim Filter As String
Dim textDisplay As String
Dim resultReceived As String
Filter = "[LastModificationTime] > '1/1/1900'"
Set oTable = oFolder.GetTable(Filter)
oTable.Columns.RemoveAll
With oTable.Columns
.Add ("SenderName")
'.Add ("SenderEmailAddress")
.Add ("Subject")
.Add ("LastModificationTime")
End With
Do Until (oTable.EndOfTable)
Set oRow = oTable.GetNextRow()
textDisplay = oRow("SenderName") & " | " & oRow("Subject") & " | " & oRow("LastModificationTime")
resultReceived = textDisplay & "§" & resultReceived
Loop
With Me.ListBox1
.Clear
.List = Split(resultReceived, "§")
.RemoveItem (Me.ListBox1.ListCount - 1)
End With
End Sub