Getting attachment file size in outlook VBA - vba

I receive emails and would like to save size of attachment in Excel sheet.
I can save size of email but I can't get size of attachment.
I looked up attachment.Size Property in MSDN, but it doesn't work. Could you please take a loop my for loop? I've attached my code below. I appreciate it if anyone would help.
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim OutlookMail As Variant
Dim Folder As MAPIFolder
Dim olItems As Outlook.Items
Dim myItems As Outlook.Items
Dim olShareName As Outlook.Recipient
Dim dStart As Date
Dim dEnd As Date
Dim i As Integer
Dim sFilter As String
Dim sFilterLower As String
Dim sFilterUpper As String
Dim sFilterSender As String
'========================================================
'access to shared mailbox to get items
'========================================================
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set olShareName = OutlookNamespace.CreateRecipient("teammailbox#example.ca")
Set Folder = Session.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("Subfolder1").Folders("Subfolder2")
Set olItems = Folder.Items
dStart = Range("From_Date").Value
dEnd = Range("To_Date").Value
'========================================================
'Conditions for restrict to get items specificed date
'========================================================
sFilterLower = "[ReceivedTime] > '" & Format(dStart, "ddddd h:nn AMPM") & "'"
sFilterUpper = "[ReceivedTime] < '" & Format(dEnd, "ddddd h:nn AMPM") & "'"
sFilterSender = "[SenderName] = ""jon.doe#example.com"""
'========================================================
'Restrict emails followed by above conditions
'========================================================
Set myItems = olItems.Restrict(sFilterLower)
Set myItems = myItems.Restrict(sFilterUpper)
Set myItems = myItems.Restrict(sFilterSender)
'========================================================
'items(emails) display in worksheets
'========================================================
i = 1
For Each myItem In myItems
MsgBox myItem.Attachments.Size
Range("eMail_subject").Offset(i, 0).Value = myItem.Subject
Range("eMail_date").Offset(i, 0).Value = Format(myItem.ReceivedTime, "h:nn")
Range("eMail_size").Offset(i, 0).Value = myItem.Size
i = i + 1
Next myItem
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
Sub sbClearCellsOnlyData()
Rows("5:" & Rows.Count).ClearContents
End Sub

The VBEditor has a great built-in tool for debugging. If you press Ctrl+F9, while selecting the myItem text with your mouse cursor you would be able to see it. It is called "Local Window" (or in German - "überwachungsausdrücke")
Long stroy short, give it a try like this in the code:
MsgBox myItem.Attachments.Item(1).Size
Instead of:
MsgBox myItem.Attachments.Size
Before doing this, it is a good idea to see whether the attachment exists:
If myItem.Attachments.Count > 0 Then

Attachment.Size property is not the size of the file blob - it is the size of the attachment record in the message store, which includes the attachment data, file name, and various other MAPI properties.
If you only want the file data, you can either use Extended MAPI (C++ or Delphi) to open the blob (PR_ATTACH_DATA_BIN) as IStream and call IStream::Stat. If you are limited to using the Outlook Object Model only, the only workaround is saving the attachment as file (Attachment.SaveAsFile) and then retrieving the file size.

I got hint from #Vityata and my below code is fixed and it works now.
For Each myItem In myItems
Range("eMail_subject").Offset(i, 0).Value = myItem.Subject
Range("eMail_date").Offset(i, 0).Value = Format(myItem.ReceivedTime, "h:nn")
If myItem.Attachments.Count > 0 Then
Range("eMail_size").Offset(i, 0).Value = myItem.Attachments.Item(1).Size / 1024 'convert to 3 digits (KB)
Else
Range("eMail_size").Offset(i, 0).Value = "No attached file"
End If
i = i + 1
Next myItem

Related

Why does loop in email inbox from latest email skip files?

I am trying to download the email attachments in Outlook inbox based on received date. My code downloads attachments, however it skips files.
For example: I was trying to loop the email from the latest email (Received date:01/14/2019). After looping around 10-15 emails, it suddenly jumps to read the email received on 12/07/2018.
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Outlook.MailItem
Set olmail = objOL.CreateItem(olMailItem)
Dim olattachment As Outlook.Attachment
Dim i As Long
Dim filename As String
Dim VAR As Date
'Loop through all item in Inbox
For i = olfolder.Items.Count To 1 Step -1 'Iterates from the end backwards
Set olmail = olfolder.Items(i)
For Each olmail In olfolder
VAR = Format(olmail.ReceivedTime, "MM/DD/YYYY")
filename = olmail.Subject
If VAR = "1/14/2019" Then
For Each olattachment In olmail.Attachments
olattachment.SaveAsFile "C:\Users\Rui_Gaalh\Desktop\Email attachment\" & olattachment.filename
Next
Else
End If
'Mark email as read
olmail.UnRead = False
DoEvents
olmail.Save
Next
Next
MsgBox "DONE"
End Sub
Do not loop through all items in a folder - some folders can have ten of thousands of messages. Use Items.Find/FindNext or Items.Restrict with a query like "[ReceivedTime] >= '2019-01-14' AND [ReceivedTime] < '2019-01-15'".
In case of Items.Find/FindNext, you won't have a problem with skipped emails. In case of Items.Restrict, use a down loop from count down to 1 step -1.
If you are just trying to save Email Attachments that was received on "1/14/2019" then No need for
For Each olmail In olfolder
Next
When you are already using
For i = olfolder.Items.Count To 1 Step -1
next
Here is another one objOL.CreateItem(olMailItem)?? remove it, also Dim olmail as a generic Object - there are objects other than MailItem in your Inbox.
Dim olmail As Outlook.MailItem
Set olmail = objOL.CreateItem(olMailItem)
Set olMail with in the loop then check if the olMail is MailItem
Example
Option Explicit
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.NameSpace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Object
Dim olattachment As Outlook.attachment
Dim i As Long
Dim filename As String
Dim VAR As Date
'Loop through all item in Inbox
For i = olfolder.items.Count To 1 Step -1 'Iterates from the end backwards
DoEvents
Set olmail = olfolder.items(i)
If TypeOf olmail Is Outlook.MailItem Then
VAR = Format(olmail.ReceivedTime, "MM/DD/YYYY")
filename = olmail.Subject
If VAR = "1/14/2019" Then
For Each olattachment In olmail.Attachments
olattachment.SaveAsFile _
"C:\Users\Rui_Gaalh\Desktop\Email attachment\" _
& olattachment.filename
Next
'Mark email as read
olmail.UnRead = False
End If
End If
Next
MsgBox "DONE"
End Sub
You should also look into Items.Restrict method
https://stackoverflow.com/a/48311864/4539709
Items.Restrict method is an alternative to using the Find method or FindNext method to iterate over specific items within a collection. The Find or FindNext methods are faster than filtering if there are a small number of items. The Restrict method is significantly faster if there is a large number of items in the collection, especially if only a few items in a large collection are expected to be found.
Filtering Items Using a String Comparison that DASL filters support includes equivalence, prefix, phrase, and substring matching. Note that when you filter on the Subject property, prefixes such as "RE: " and "FW: " are ignored.
Thanks for all your suggestions. The code works perfectly. Please find the final code below:
Option Explicit
Sub saveemailattachment()
'Application setup
Dim objOL As Outlook.Application
Set objOL = New Outlook.Application
Dim ONS As Outlook.Namespace
Set ONS = objOL.GetNamespace("MAPI")
Dim olfolder As Outlook.Folder
Set olfolder = ONS.GetDefaultFolder(olFolderInbox)
Dim olmail As Object
Dim olattachment As Outlook.Attachment
Dim i As Long
Dim InboxMsg As Object
Dim filename As String
'Set variables
Dim Sunday As Date
Dim Monday As Date
Dim Savefolder As String
Dim VAR As Date
Dim Timestamp As String
Monday = ThisWorkbook.Worksheets(1).Range("B2")
Sunday = ThisWorkbook.Worksheets(1).Range("B3")
Savefolder = ThisWorkbook.Worksheets(1).Range("B4")
'Loop through all item in Inbox
For i = olfolder.Items.Count To 1 Step -1 'Iterates from the end backwards
DoEvents
Set olmail = olfolder.Items(i)
Application.Wait (Now + TimeValue("0:00:01"))
'Check if olmail is emailitem
If TypeOf olmail Is Outlook.MailItem Then
'Set time fram
VAR = olmail.ReceivedTime 'Set Received time
Timestamp = Format(olmail.ReceivedTime, "YYYY-MM-DD-hhmmss") 'Set timestamp format
If VAR <= Sunday And VAR >= Monday Then
For Each olattachment In olmail.Attachments
Application.Wait (Now + TimeValue("0:00:01"))
'Download excel file and non-L10 file only
If (Right(olattachment.filename, 4) = "xlsx" Or Right(olattachment.filename, 3) = "xls")Then
'Set file name
filename = Timestamp & "_" & olattachment.filename
'Download email
olattachment.SaveAsFile Savefolder & "\" & filename
Application.Wait (Now + TimeValue("0:00:02"))
End If
Next
Else
End If
'Mark email as read
olmail.UnRead = False
DoEvents
olmail.Save
Else
End If
Next
MsgBox "DONE"
End Sub

Excel VBA Logic idea

My script is for tracking emails with subject and received time.
I receive 4 emails daily and I need to make reports about when email receiving.
My question is I create check box that allow which emails I want to track, but I don't know how can I make logically. First I tried , I created 15 if statements. I know it's not good so I am looking for new logic. I have attached my code below.
Please share your knowledge.
Plus, restrict method is for specified date and sender.
Sub GetFromOutlook()
Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim OutlookMail As Variant
Dim Folder As MAPIFolder
Dim olItems As Outlook.Items
Dim myItems As Outlook.Items
Dim olShareName As Outlook.Recipient
Dim dStart As Date
Dim dEnd As Date
Dim i As Integer
Dim sFilter As String
Dim sFilterLower As String
Dim sFilterUpper As String
Dim sFilterSender As String
'========================================================
'access to shared mailbox to get items
'========================================================
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set olShareName = OutlookNamespace.CreateRecipient("Mailbox.teamshared#example.ca")
Set Folder = Session.GetSharedDefaultFolder(olShareName, olFolderInbox).Folders("subfolder1").Folders("subfolder2")
Set olItems = Folder.Items
'========================================================
'If check box is checked
'========================================================
dStart = Range("From_Date").Value
dEnd = Range("To_Date").Value
'========================================================
'Conditions for restrict to get items specificed date
'========================================================
sFilterLower = "[ReceivedTime] > '" & Format(dStart, "ddddd h:nn AMPM") & "'"
sFilterUpper = "[ReceivedTime] < '" & Format(dEnd, "ddddd h:nn AMPM") & "'"
sFilterSender = "[SenderName] = ""no-reply#example.com"""
'========================================================
'Restrict emails followed by above conditions
'========================================================
Set myItems = olItems.Restrict(sFilterLower)
Set myItems = myItems.Restrict(sFilterUpper)
Set myItems = myItems.Restrict(sFilterSender)
'========================================================
'items(emails) display in worksheets
'========================================================
i = 1
For Each myItem In myItems
Range("eMail_subject").Offset(i, 0).Value = myItem.Subject
Range("eMail_date").Offset(i, 0).Value = Format(myItem.ReceivedTime, "h:nn")
'Convert size KB
If myItem.Attachments.Count > 0 Then
Range("eMail_size").Offset(i, 0).Value = myItem.Attachments.Item(1).Size / 1024
Else
Range("eMail_size").Offset(i, 0).Value = "No attached file"
End If
i = i + 1
Next myItem
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
Else
MsgBox "You have check at least one"
End If
End Sub

How to get Outlook Email received time

I need to extract attachments from Emails received in a user preferred time frame.
Say like extract for Emails received between 2PM to 4PM.
Please find the below code I've that extract files perfectly - but it did for all the Emails in the folder.
Please help me to resolve it.
Sub Unzip()
Dim ns As NameSpace 'variables for the main functionality
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As Variant
Dim msg As Outlook.MailItem
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Dim FileNameFolder As Variant
Dim Totalmsg As Object
Dim oFrom
Dim oEnd
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("TEST")
Set Totalmsg = msg.ReceivedTime
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
If Totalmsg <= oFrom And Totalmsg >= oEnd Then
For Each msg In SubFolder.Items
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
MsgBox "1"
FileNameFolder = "C:\Users\xxxx\Documents\test\"
FileName = FileNameFolder & Atchmt.FileName
Atchmt.SaveAsFile FileName
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(FileName).Items
Kill (FileName)
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
Next
End If
End Sub
Made a few improvements to improve performance and clarity :
Test received time inside the loop on the messages
Defined related variables as Date (like MsG.ReceivedTime) and improved input messages
Added Option Explicit to avoid mishaps in future coding (VERY GOOD PRACTICE)
Use Environ$("USERPROFILE") to get User directory's path
Reorganize variables and initialisation outside of the loops
Added LCase to be sure to get all zips (including .ZIP)
Code :
Option Explicit
Sub Unzip()
'''Variables for the main functionality
Dim NS As NameSpace
Dim InboX As MAPIFolder
Dim SubFolder As MAPIFolder
Dim MsG As Outlook.MailItem
Dim AtcHmt As Attachment
Dim ReceivedHour As Date
Dim oFrom As Date
Dim oEnd As Date
'''Variables for unzipping
Dim FSO As Object
Dim ShellApp As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ShellApp = CreateObject("Shell.Application")
Dim FileNameFolder As Variant
Dim FileName As Variant
'''Define the Outlook folder you want to scan
Set NS = GetNamespace("MAPI")
Set InboX = NS.GetDefaultFolder(olFolderInbox)
Set SubFolder = InboX.Folders("TEST")
'''Define the folder where you want to save attachments
FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"
'''Define the hours in between which you want to apply the extraction
oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
"Example: 9AM", ("Shadowserver report"), "9AM"))
oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
"Example: 6PM", ("Shadowserver report"), "6PM"))
For Each MsG In SubFolder.items
ReceivedHour = MsG.ReceivedTime
If oFrom <= TimeValue(ReceivedHour) And _
TimeValue(ReceivedHour) <= oEnd Then
For Each AtcHmt In MsG.Attachments
FileName = AtcHmt.FileName
If LCase(Right(FileName, 3)) <> "zip" Then
Else
FileName = FileNameFolder & FileName
AtcHmt.SaveAsFile FileName
ShellApp.NameSpace(FileNameFolder).CopyHere _
ShellApp.NameSpace(FileName).items
Kill (FileName)
On Error Resume Next
FSO.deletefolder Environ$("Temp") & "\Temporary Directory*", True
End If
Next AtcHmt
End If
Next MsG
End Sub
I am just going to include the part that you need to change. Other lines will be the same. Basically, what you need to do is to set the Totalmsg inside your loop for each msg;
Sub Unzip()
'... copy your code till here
Set SubFolder = Inbox.Folders("TEST")
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
For Each msg In SubFolder.Items
Set Totalmsg = msg.ReceivedTime
If Totalmsg <= oFrom And Totalmsg >= oEnd Then 'You check it for each msg
'rest will be the same until ...
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
End If
Next
End Sub

Outlook scan through the Inbox for a specific string in the subject

I'm working on a project were I need a macro in outlook that will scan through the inbox for an e-mail with a "reference number" contained with-in the subject field. If no e-mail was detected, the system can then move on to the next reference from an excel spreadsheet.
If an e-mail was detected, it gets extracted as an "MSG" file and the actual e-mail moved into a subfolder. So far I have a code for extracting the e-mails as "MSG" files but I cant get it to identify the specific string (reference No) in the subject field. I got the below EXCEL Macro code so far from this site.
Sub Work_with_Outlook()
Set outlookApp = CreateObject("Outlook.Application")
Dim olNs As Outlook.NameSpace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim sir() As String
Set outlookApp = New Outlook.Application
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
Set olMail = myTasks.Find("[Subject] = ""Macro""")
If Not (olMail Is Nothing) Then
olMail.Display
End If
End Sub
Try below code:
Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myFolder, destFolder As Outlook.MAPIFolder
Dim i, lr As Long
'last used row in excel
lr = Cells(Rows.Count, "A").End(xlUp).Row
Set myOlapp = GetObject(, "Outlook.application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set destFolder = myFolder.Folders("provide subFolderName here")
Set mytask = myFolder.Items
'Download and move attachment if found
For i = 1 To lr
'The below line of code will not work if you are using wild card or partial string
Set ref = mytask.Find("[Subject] =" & Range("a" & i).Value)
If Not (ref Is Nothing) Then
ref.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
ref.Move destFolder
End If
Set ref = Nothing
'The workaround code goes as below
For Each myItem In mytask
If myItem.Class = olMail Then
If InStr(1, myItem.Subject, Range("a" & i).Value) > 0 Then
myItem.Attachments.Item(1).SaveAsFile "C:\" & Range("a" & i).Value & ".msg"
myItem.Move destFolder
End If
End If
Next myItem
Next i
Set myOlapp = Nothing
Set myNameSpace = Nothing
Set myFolder = Nothing
Set destFolder = Nothing
Set mytask = Nothing
End Sub
Note: Assuming reference number is in "A" Column

Check e-mails in specific time frame

I need to check items in a folder in a specific time frame.
My code goes through all the mails in the specified folder, but the folder has thousands of mails, so it takes forever.
How do I check the mails only from, for example, 3/16/2015 12:00PM to 3/16/2015 2:00PM?
This is what I have:
Sub ExportToExcel()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim workbookFile As String
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'Folder path and file name of an existing Excel workbook
workbookFile = "C:\Users\OutlookItems.xls"
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, _
"Error"
Exit Sub
End If
' Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
Set wkb = appExcel.Workbooks.Open(workbookFile)
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
Set rng = wks.Range("A1")
'Copy field items in mail folder.
For Each itm In fld.Items
If itm.Class = Outlook.OlObjectClass.olMail Then
Set msg = itm
If InStr(msg.Subject, "Error in WU_Send") > 0 And DateDiff("h", msg.SentOn, Now) <= 2 Then
rng.Offset(0, 4).Value = msg.Body
Set rng = rng.Offset(1, 0)
End If
End If
Next
End Sub
The problem lies in this part:
For Each itm In fld.Items
If itm.Class = Outlook.OlObjectClass.olMail Then
Set msg = itm
If InStr(msg.Subject, "Error in WU_Send") > 0 And DateDiff("h", msg.SentOn, Now) <= 2 Then
How do I look at e-mails between specified hours?
You need to use the Find/FindNext or Restrict methods of the Items class instead of iterating through all items in the folder. For example:
Sub DemoFindNext()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
While TypeName(currentAppointment) <> "Nothing"
MsgBox currentAppointment.Subject
Set currentAppointment = myAppointments.FindNext
Wend
End Sub
See the following articles for more information and sample code:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Also you may find the AdvancedSearch method of the Application class helpful. The key benefits of using the AdvancedSearch method are listed below:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
You could just change the line to:
If InStr(msg.Subject, "Error in WU_Send") > 0 And msg.SentOn > "03/16/2015 12:00 PM" AND msg.SentOn < "03/16/2015 2:00 PM" Then
This specifies the time period.
Option Explicit
Sub RestrictTimePeriod()
Dim nms As Namespace
Dim fld As folder ' Subsequent to 2003 otherwise MAPIFolder
Dim msg As MailItem
Dim filterCriteria As String
Dim filterItems As Items
Dim i As Long
Dim start
Dim dif
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
If Not fld Is Nothing Then
start = Now
Debug.Print start
' http://www.jpsoftwaretech.com/use-filters-to-speed-up-outlook-macros/
filterCriteria = "[ReceivedTime] > " & QuoteWrap("2015-03-16 12:00 PM") & _
" And [ReceivedTime] < " & QuoteWrap("2015-03-17 2:00 PM")
Set filterItems = fld.Items.Restrict(filterCriteria)
For i = filterItems.count To 1 Step -1
Set msg = filterItems.Item(i)
Debug.Print msg.Subject
Next
End If
ExitRoutine:
Set nms = Nothing
Set msg = Nothing
Set filterItems = Nothing
Debug.Print Now
dif = (Now - start) * 86400
Debug.Print dif
Debug.Print "Done."
End Sub
Function QuoteWrap(stringToWrap As String, _
Optional charToUse As Long = 39) As String
' http://www.jpsoftwaretech.com/use-filters-to-speed-up-outlook-macros/
' use 34 for double quotes, 39 for apostrophe
QuoteWrap = Chr(charToUse) & stringToWrap & Chr(charToUse)
End Function