Excel VBA Outlook search Multiple Criteria (ID and Date) - vba

This code was derived from Excel VBA for searching in mails of Outlook.
I made adjustments to make it search a SharedMailbox which does work but the issue is that the mailbox is receiving hundreds of emails a day which makes searching time a bit longer for my liking (we have emails from early last year even). I would like to impose a 2nd search criteria, this time a date limit, like only search emails that are 2 to 3 days old.
Here is what I got:
Dim outlookapp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim projIDsearch As String
Dim myRecipient As Outlook.Recipient
Dim days2ago As Date
Set outlookapp = CreateObject("Outlook.Application")
Set olNs = outlookapp.GetNamespace("MAPI")
Set myRecipient = olNs.CreateRecipient("SharedMailboxName")
myRecipient.Resolve
'Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("x")
Set Fldr = olNs.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Set myTasks = Fldr.Items
projIDsearch = ActiveCell.Cells(1, 4)
days2ago = DateTime.Now - 3
For Each olMail In myTasks
'If olMail.ReceivedTime > days2ago Then
If (InStr(1, olMail.Subject, projIDsearch, vbTextCompare) > 0) Then
olMail.Display
'Exit For
End If
Next
I've looked around and found the .ReceivedTime property, which sounds like the thing that I need but I'm having a struggle on how to incorporate it into the code.
Actually I don't even know how a Variant(olMail) is able to accept the .display method and .subject property.
These are the codes that I've added but they don't seem to work:
days2ago = DateTime.Now - 3
and
If olMail.ReceivedTime > days2ago Then

You can Restrict the number of items in the loop. https://msdn.microsoft.com/en-us/library/office/ff869597.aspx
Sub test()
Dim outlookapp As Object
Dim olNs As Outlook.Namespace
Dim myFldr As Outlook.Folder
Dim objMail As Object
Dim myTasks As Outlook.Items
Dim daysAgo As Long
Dim projIDsearch As String
Dim myRecipient As Outlook.Recipient
Set outlookapp = CreateObject("Outlook.Application")
Set olNs = outlookapp.GetNamespace("MAPI")
Set myRecipient = olNs.CreateRecipient("SharedMailboxName")
myRecipient.Resolve
Set myFldr = olNs.GetSharedDefaultFolder(myRecipient, olFolderInbox)
projIDsearch = ActiveCell.Cells(1, 4)
' Restrict search to daysAgo
daysAgo = 3
Set myTasks = myFldr.Items.Restrict("[ReceivedTime]>'" & Format(Date - daysAgo, "DDDDD HH:NN") & "'")
For Each objMail In myTasks
If (InStr(1, objMail.Subject, projIDsearch, vbTextCompare) > 0) Then
objMail.Display
End If
Next
End Sub

Related

Search for a specific Outlook email

What Visual Basic for Applications method will allow me to find a specific Outlook email so that I can access data from it like its message content - perhaps by searching by the subject of the email?
Items.Find Method is a alternative solution, you can use VBA string search function:
Sub sofWorkWithOutlook20082550()
Dim outlookApp
Dim olNs As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Variant
Dim myTasks
Dim sir() As String
'Set outlookApp = New Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Set olNs = outlookApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set myTasks = Fldr.Items
'
'Set olMail = myTasks.Find("[Subject] = ""123456""")
'
For Each olMail In myTasks
'
If (InStr(1, olMail.Body, "My-Text-to-Search", vbTextCompare) > 0) Then
olMail.Display
Exit For
End If
Next
End Sub
PS: change "My-Text-to-Search" to some string you have in your email
Acess this site for more information: Items.Find Method

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

Skip already categorized mails

Current Code:
Dim outlookapp
Dim olns As Outlook.Namespace
Dim Fldr As Outlook.MAPIFolder
Dim olMail As Object
'Dim olMail As Outlook.MailItem
Dim myTasks
Dim projIDsearch As String
Dim myrecipient As Outlook.Recipient
Dim daysAgo As Long
Set outlookapp = CreateObject("Outlook.Application")
Set olns = outlookapp.GetNamespace("MAPI")
Set myrecipient = olns.CreateRecipient("Ccbcphelpdesk")
myrecipient.Resolve
'Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("ExemptionReview")
Set Fldr = olns.GetSharedDefaultFolder(myrecipient, olFolderInbox)
' Restrict search to daysAgo
daysAgo = 0
Set myTasks = Fldr.Items.Restrict("[ReceivedTime]>'" & Format(Date - daysAgo, "DDDDD HH:NN") & "'")
projIDsearch = ActiveCell.Cells(1, 4)
For Each olMail In myTasks
If (InStr(1, olMail.Subject, projIDsearch, vbTextCompare) > 0) Then
olMail.Categories = "ESP"
olMail.Save
End If
Next
end sub
This looks up emails pertaining to a search string in the subject then tags them as ESP. I need to skip emails that are already categorized.
I have tried:
If (InStr(1, olMail.Subject, projIDsearch, vbTextCompare) > 0) Then
If olmail.categories Is nothing then 'line returns and error 424
olMail.Categories = "ESP"
olMail.Save
End If
End If
How can I skip Emails that are already categorized and only categorize emails with no category?
https://msdn.microsoft.com/en-us/library/office/ff860423.aspx
Categories is a String-type property, so test with something like:
If Len(olmail.Categories) = 0 Then
Use Logical Operators And Not on your Restrict method
Set myTasks = Fldr.Items.Restrict("[ReceivedTime]>'" & Format(Date - daysAgo, "DDDDD HH:NN") & "' And Not [Categories] = 'ESP'")
and remove your If olmail.categories Is nothing that way your not checking every olmail- and it should speedup your loop

Searching for newest email with a certain subject

I have the below code which works.
I now need to find the newest email with that subject line and open it.
Once the email is opened, I'd like to save the attachment to my desktop and close out of the opened email.
Sub SearchOL()
Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim olMail As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
i = 1
For Each olMail In Fldr.Items
If InStr(olMail.Subject, "DNP Warn and Pend Event") <> 0 Then
olMail.Display
i = i + 1
End If
Next olMail
End Sub
I'd suggest starting from the Getting Started with VBA in Outlook 2010 article in MSDN.
Use the Find/FindNext or Restrict methods of the Items class to find the emails with a particular subject line instead of iterating through each email and checking the subject line.
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

How to delete appointments?

I have code that is supposed to loop through all future appointments; and if they match a certain criteria, delete them from the calendar.
Sub DeleteFutureImportedCalendarItems()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objAppointment As Outlook.AppointmentItem
Dim strSubject As String
Dim strLocation As String
Dim dteStartDate As Date
Dim Category As String
'******************************** Set Criteria for DELETION here ********************************
strSubject = "[Imported]"
strLocation = "AC"
dteStartDate = Date
Category = "Yellow Category"
'************************************************************************************************
Set objOutlook = Outlook.Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.GetDefaultFolder(olFolderCalendar)
For Each objAppointment In objFolder.Items
If Right(objAppointment.Subject, 10) = strSubject And objAppointment.Location = strLocation And _
objAppointment.Start >= dteStartDate And objAppointment.Categories = Category Then
objAppointment.Delete
End If
Next
End Sub
This does not delete all of the appointments that meet the criteria. If I run the code multiple times, it grabs a few more each time, but I have to run this 5 or 6 times to get all of them.
Deleting an item changes the collection. Loop from Count down to 1 instead:
set oItems = objFolder.Items
for i = oItems.Count to 1 step -1 do
set objAppointment = oItems.Item(I)
...