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

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

Related

Move mail folders and subfolders on shared mail box to delete shared folder

I have the following code in Outlook. On my first attempt the deleted mail was sent to my main account inbox and not the shared mailbox.
I would like to
1- pick the shared delete folder by default
2- avoid looping the delete folder
3- speed up the code if possible as size of mail box is > 1 Million mails.
It is error free but I can track the progress.
Dim objNameSpace As Outlook.NameSpace
Dim objMainFolder As Outlook.Folder
Dim olNs As NameSpace
Dim lngItem As Long
Dim Mails_itm As MailItem
Dim myNameSpace As Outlook.NameSpace
Dim myInboxDest As Outlook.Folder
Dim myInboxSc As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim myItem As Object
Set objNameSpace = Application.GetNamespace("MAPI")
Set objMainFolder = objNameSpace.PickFolder
Call ProcessCurrentFolder(objMainFolder)
End Sub
ProcessCurrentFolder(ByVal objParentFolder As Outlook.MAPIFolder)
Dim objCurFolder As Outlook.MAPIFolder
Dim objMail As Outlook.MailItem
Dim DeletedFolder As Outlook.Folder
Dim olNs As Outlook.NameSpace
Dim lngItem As Long
On Error Resume Next
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
For Each objMail In objParentFolder.Items
i = 0
For lngItem = objParentFolder.Items.Count To 1 Step -1
Set objMail = objParentFolder.Items(lngItem)
If TypeName(objMail) = "MailItem" Then
If ((objMail.ReceivedTime) < DateAdd("yyyy", -7, Date)) Then
objMail.Move DeletedFolder
i = i + 1
End If
End If
DoEvents
Next lngItem
Next
If (objParentFolder.Folders.Count > 0) Then
For Each objCurFolder In objParentFolder.Folders
Call ProcessCurrentFolder(objCurFolder)
Next
End If
End Sub
When placing a question, it is good to check it from time to time and answer the clarification questions, if any...
Supposing that your first required issue means replacing the folder picker option and directly setting objMainFolder, your first code should be adapted as:
Sub ProcessOldMails()
Dim objNameSpace As outlook.NameSpace
Dim objMainFolder As outlook.Folder
Set Out = GetObject(, "Outlook.Application")
Set objNameSpace = Out.GetNamespace("MAPI")
Set objNameSpace = Application.GetNamespace("MAPI")
'Set objMainFolder = objNameSpace.PickFolder 'uncomment if my supposition is wrong
'set the folder to be processed directly, if it is an InBox subfolder:
'Please use its real name instead of "MyFolderToProcess":
Set objMainFolder = objNameSpace.GetDefaultFolder(olFolderInbox).Folders("MyFolderToProcess")
ProcessCurrentFolder objMainFolder, Application
End Sub
In order to make the process faster, you can filter the folder content and iterate only between the remained mails:
Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
Dim objCurFolder As outlook.MAPIFolder
Dim objMail As outlook.MailItem
Dim DeletedFolder As outlook.Folder
Dim olNs As outlook.NameSpace
Dim lngItem As Long, strFilter As String, oItems As items
Set olNs = app.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
strFilter = "[ReceivedTime]<'" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
For lngItem = oItems.count To 1 Step -1
oItems(lngItem).Move DeletedFolder
Next lngItem
If (objParentFolder.Folders.count > 0) Then
For Each objCurFolder In objParentFolder.Folders
Call ProcessCurrentFolder(objCurFolder, app)
Next
End If
End Sub
I used app second parameter only because I tried it as an Outlook automation from Excel, and it was easier to insert only two lines...
Please, test the suggested solution and send some feedback. If my understanding was not a correct one, do not hesitate to ask for clarifications, firstly answering my questions from the comment.
Now, I need to go out...
Use the Find/FindNext or Restrict methods to get items that correspond to your conditions instead of iterating over all items in the folder. Read more about these methods in the following articles:
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
When you iterate over found items and move them to another folder you must use a reverse loop which allows prevent errors at runtime because decreasing the number of items by calling the Move method leads to decreasing the number of items.
Sub ProcessCurrentFolder(ByVal objParentFolder As outlook.MAPIFolder, app As outlook.Application)
Dim objCurFolder As outlook.MAPIFolder
Dim objMail As outlook.MailItem
Dim DeletedFolder As outlook.Folder
Dim olNs As outlook.NameSpace
Dim lngItem As Long, strFilter As String, oItems As items
Set olNs = app.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
strFilter = "[ReceivedTime] < '" & Format(DateAdd("yyyy", -7, Date), "DDDDD HH:NN") & "'"
Set oItems = objParentFolder.items.Restrict(strFilter) 'extract only mails older then 7 years
Debug.Print "Mails to be moved to Deleted Items: " & oItems.count 'just to see how many such folders exist
For i = oItems.Count to 1 Step -1
Set objMail = oItems(i)
objMail.Move DeletedFolder
Next
' it makes sense to move this part to the beginning of the method to process subfolders first
If (objParentFolder.Folders.count > 0) Then
For Each objCurFolder In objParentFolder.Folders
Call ProcessCurrentFolder(objCurFolder, app)
Next
End If
End Sub
See For Each loop: Some items get skipped when looping through Outlook mailbox to delete items for more information.

Save Attachment on arriving email

I created an Outlook rule to save an attachment then move it to the Deleted Items folder. The code works when I highlight the arrived email in the Inbox then move the email to the Deleted Items folder.
When the new email arrives, it is saving the attachment(s) from different email in the inbox and not moving the email to the Deleted Items folder.
The Outlook rule is:
Apply this rule after the message arrives
from Sender
and with Gift Card in the subject
and on this computer only
run Project1.SaveAttachments
Public Sub SaveAttachments(MItem As Outlook.Mailitem)
Dim objOL As Outlook.Application
Dim objMsg As Outlook.Mailitem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objSelection = objOL.ActiveExplorer.Selection
strFolderpath = "Y:\"
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
strDeletedFiles = ""
If lngCount > 0 Then
For i = lngCount To 1 Step -1
strFile = objAttachments.Item(i).FileName
strFile = strFolderpath & strFile
objAttachments.Item(i).SaveAsFile strFile
Next i
Set objNamespace = objOL.GetNamespace("MAPI")
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderDeletedItems)
objMsg.Move objDestFolder
End If
Next
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
Set objNamespace = Nothing
Set objDestFolder = Nothing
End Sub
According to my test, you could save email attachment and delete it using the below code:
Sub SaveAutoAttach()
Dim object_attachment As Outlook.attachment
Dim saveFolder As String
Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object
Dim some As String, other As String
Const olFolderInbox = 6
'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")
If unRead.Count = 0 Then
MsgBox "NO Unread Email In Inbox"
Else
some = ""
other = ""
saveFolder = "D:\"
For Each m In unRead
If m.Attachments.Count > 0 Then
For Each object_attachment In m.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".doc") Then
object_attachment.SaveAsFile saveFolder & "\" & object_attachment.DisplayName
End If
Next
End If
m.Delete
Next m
End Sub
For more information, please refer to this link:
Auto Download Outlook Email Attachment – Code in VBA by Topbullets.com

Excel VBA Outlook search Multiple Criteria (ID and Date)

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

Emails to a distribution group aren't MailItems?

I'm trying to write a VBA script for Outlook 2007 that moves a user's mail to an "Expired" folder if it's older than 89 days. I have code to do this, but it doesn't seem to work for aged emails that were to a distribution group that includes the end user. It works for emails just sent to the end user.
I combined code I found online for a) moving emails when they are a certain number of days old (http://www.slipstick.com/developer/macro-move-aged-mail/), and b) recursing through a folder to apply the code to subfolders as well (Can I iterate through all Outlook emails in a folder including sub-folders?). This code recurses through the Inbox folder and subfolders to move all aged mail.
It more or less works, but for some reason emails to a distribution list that includes the end user are not being picked up. The only remarkable check I have is that
If TypeName(oItem) = "MailItem"
Are distribution list emails not considered MailItems? If not, how do I make sure to catch those too?
Here is the complete code:
Public Sub MoveAgedMail(Item As Outlook.MailItem)
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim Folder As Outlook.MAPIFolder
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
' Call processFolder
processFolder objSourceFolder
End Sub
Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim oItem As Object
Dim intCount As Integer
Dim intDateDiff As Long
Dim objDestFolder As Outlook.MAPIFolder
' "Expired" folder at same level as Inbox for sending aged mail
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")
For Each oItem In oParent.Items
If TypeName(oItem) = "MailItem" Then
Set oMail = oItem
' Check if email is older than 89 days
intDateDiff = DateDiff("d", oMail.SentOn, Now)
If intDateDiff > 89 Then
' Move to "Expired" folder
oMail.Move objDestFolder
End If
End If
Next oItem
' Recurse through subfolders
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
Set objDestFolder = Nothing
End Sub
Firstly, do not use for each if you are modifying a collection - that will cause your code to skip half the items.
Secondly, do not just loop through all items in a folder, this is extremely inefficient. Use Items.Restrict or Items.Find/FindNext.
Try something like the following (VB script):
d = Now - 89
strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
set oItems = oParent.Items.Restrict(strFilter)
for i = oItems.Count to 1 step -1
set oItem = oItems.Item(i)
Debug.Print oItem.Subject & " " & oItem.SentOn
next
Try not to process Expired Folder
' Recurse through subfolders
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
Debug.Print oFolder
' No need to process Expired folder
If oFolder.Name <> "Expired" Then
processFolder oFolder
End If
Next
End If
also try using down loop when moving mail items, see Dmitry Streblechenko example
Edit
Items.Restrict Method (Outlook)
Complete Code- Tested on Outlook 2010
Sub MoveAgedMail(Item As Outlook.MailItem)
Dim olNameSpace As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olNameSpace = Application.GetNamespace("MAPI")
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
' // Call ProcessFolder
ProcessFolder olInbox
End Sub
Function ProcessFolder(ByVal Parent As Outlook.MAPIFolder)
Dim Folder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
Dim iCount As Integer
Dim iDateDiff As Long
Dim vMail As Variant
Dim olItems As Object
Dim sFilter As String
iDateDiff = Now - 89
sFilter = "[SentOn] < '" & Month(iDateDiff) & "/" & Day(iDateDiff) & "/" & Year(iDateDiff) & "'"
' // Loop through the items in the folder backwards
Set olItems = Parent.Items.Restrict(sFilter)
For iCount = olItems.Count To 1 Step -1
Set vMail = olItems.Item(iCount)
Debug.Print vMail.Subject ' helps me to see where code is currently at
' // Filter objects for emails
If vMail.Class = olMail Then
Debug.Print vMail.SentOn
' // Retrieve a folder for the destination folder
Set DestFolder = Session.GetDefaultFolder(olFolderInbox).Folders("Expired")
' // Move the emails to the destination folder
vMail.Move DestFolder
' // Count number items moved
iCount = iCount + 1
End If
Next
' // Recurse through subfolders
If (Parent.Folders.Count > 0) Then
For Each Folder In Parent.Folders
If Folder.Name <> "Expired" Then ' skip Expired folder
Debug.Print Folder.Name
ProcessFolder Folder
End If
Next
End If
Debug.Print "Moved " & iCount & " Items"
End Function
This is my code now. Originally, I moved my old mail to an "Expired" folder and had autoarchive delete the messages, but I was having issues with autoarchive on some machines. I rewrote the script to delete old email. It uses Dmitry Streblechenko's suggestions, and it seems to work.
Public Sub DeleteAgedMail()
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objSourceFolder As Outlook.MAPIFolder
Dim objSourceFolderSent As Outlook.MAPIFolder
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
Set objSourceFolderSent = objNamespace.GetDefaultFolder(olFolderSentMail)
processFolder objSourceFolder
processFolder objSourceFolderSent
emptyDeleted
End Sub
Public Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oItems As Outlook.Items
Dim oItem As Object
Dim intDateDiff As Long
Dim d As Long
Dim strFilter As String
d = Now - 89
strFilter = "[SentOn] < '" & Month(d) & "/" & Day(d) & "/" & Year(d) & "'"
Set oItems = oParent.Items.Restrict(strFilter)
For i = oItems.Count To 1 Step -1
Set oItem = oItems.Item(i)
If TypeName(oItem) = "MailItem" Then
oItem.UserProperties.Add "Deleted", olText
oItem.Save
oItem.Delete
End If
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
Public Sub emptyDeleted()
Dim objOutlook As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim objDeletedFolder As Outlook.MAPIFolder
Dim objProperty As Outlook.UserProperty
Set objOutlook = Application
Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set objDeletedFolder = myNameSpace.GetDefaultFolder(olFolderDeletedItems)
For Each objItem In objDeletedFolder.Items
Set objProperty = objItem.UserProperties.Find("Deleted")
If TypeName(objProperty) <> "Nothing" Then
objItem.Delete
End If
Next
End Sub
If you want to just move emails and not delete them, like in my original code, you could get rid of the emptyDeleted() function, change
oItem.UserProperties.Add "Deleted", olText
oItem.Save
oItem.Delete
back to
oItem.Move objDestFolder
and add these two lines back to the processFolder() function:
Dim objDestFolder As Outlook.MAPIFolder
Set objDestFolder = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("Expired")

Searching Outlook Folder

I want to search a specific Outlook folder using an activecell value.
I tried Excel VBA for searching in mails of Outlook and VBA Search in Outlook.
The closest I was able to get:
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myitem As Object
Dim Found As Boolean
Dim OutlookSearch as string
Outlooksearch = Cstr(Activecell.cells(1,4).Value)
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myitem In myitems
If myitem.Class = olMail Then
If InStr(1, myitem.Subject, "sketch") > 0 Then
Debug.Print "Found"
Found = True
End If
End If
Next myitem
'If the subject isn't found:
If Not Found Then
MsgBox "Cannot find"
End If
myOlApp.Quit
Set myOlApp = Nothing
I want to use the string in Activecell.cells(1, 4) as the subject for a search in a specific Outlook folder in the inbox.
I get is the MsgBox even if I've sent an email containing values that match with activecell.
You can specify the folder to search in, within the inbox, by using the .Folders property.
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox).Folders("myFolder")
I've had a play around and come up with the code below. No need to set references to Outlook.
Sub Test1()
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
Dim cFolder As Object
Dim oItem As Object
Dim oMyItem As Object
Dim sOutlookSearch As String
Dim aFolders() As String
Dim i As Long
'sOutlookSearch needs to be something like:
'"Mailbox - Darren Bartrup-Cook\Inbox"
sOutlookSearch = ThisWorkbook.Worksheets("Sheet1").Cells(1, 4)
sOutlookSearch = Replace(sOutlookSearch, "/", "\")
aFolders() = Split(sOutlookSearch, "\")
Set oOutlook = GetObject(, "Outlook.Application")
Set nNameSpace = oOutlook.GetNamespace("MAPI")
Set mFolderSelected = nNameSpace.Folders.Item(aFolders(0))
If Not mFolderSelected Is Nothing Then
For i = 1 To UBound(aFolders)
Set cFolder = mFolderSelected.Folders
Set mFolderSelected = Nothing
Set mFolderSelected = cFolder.Item(aFolders(i))
If mFolderSelected Is Nothing Then
Exit For
End If
Next i
End If
'Set mFolderSelected = nNameSpace.PickFolder 'Alternative to above code block - just pick the folder.
For Each oItem In mFolderSelected.items
If oItem.class = 43 Then '43 = olmail
If InStr(1, oItem.Subject, "sketch") > 0 Then
Debug.Print "Found: " & oItem.sendername
Exit For
End If
End If
Next oItem
End Sub
The code block for finding the correct folder was taken from here:
http://www.outlookcode.com/d/code/getfolder.htm