Scope using AdvancedSearch method for entire mailbox - vba

I am trying to look through all Outlook folders for mail items matching certain parameters to save the attachment, from Excel.
I don't know how to reference scope to go through all folders, even custom folders.
I can't find the resources that answer my question.
Sub testing()
Dim myOlApp As New Outlook.Application
Dim scope As String
Dim filter As String
Dim rsts As Results
Dim AdvancedSearch As Outlook.Search
blnSearchComp = False
'I want it to search the entire mail account including normal folders like inbox and sent as well as custom folders.
'but this doesn't work. Any ideas?
scope = "'Fakeexample123#outlook.com'"
'filter assignment statement has been excluded
Set AdvancedSearch = myOlApp.AdvancedSearch(scope, filter, True, "test")
While blnSearchComp <> True
If AdvancedSearch.Results.Count > 0 Then
blnSearchComp = True
End If
Wend
Set rsts = AdvancedSearch.Results
For x = rsts.Count To 1 Step -1
rsts.Attachment.Item(x).SaveAsFile Project
Next
End Sub

Scope should be
'\\Fakeexample123#outlook.com'
Sub Demo_scopeformat()
Dim myOlApp As New outlook.Application
Dim scope As String
' Mailbox
scope = "'" & myOlApp.Session.GetDefaultFolder(olFolderInbox).Parent.folderPath & "'"
' Expected format
Debug.Print scope
End Sub

Well, I know it isn't the best solution, but I have come up with the following code to make a list of all of the parent folders, so that a for loop can be used with advanced search method to iterate the list. This will not be the fastest possible code, but should not be too slow.
Sub main()
'establishes connections
Dim myOlApp As New Outlook.Application
Dim objNS As Outlook.Namespace
Dim myFolder As Outlook.MAPIFolder
Set objNS = myOlApp.GetNamespace("MAPI")
'pick highest folder level as original my folder
Set myFolder = objNS.Folders("faxe.example123#outlook.com")
Call ProcessFolders(myFolder)
End Sub
Sub ProcessFolders(myFolder)
're establish connections
Dim myOlApp As New Outlook.Application
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.MAPIFolder
Set objNS = myOlApp.GetNamespace("MAPI")
'set up collection
Set x = New Collection
For Each objFolder In myFolder.Folders
'add all parent folder names to collection
'advanced search method will handle subfolders
'can use a recursive call here also to get subfolders though
x.Add objFolder.Name
Next
Set objNS = Nothing
Set myFolder = Nothing
Set myOlApp = Nothing
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.

How do I select an archive folder?

I have an email account "Fred.Smith#domain.co.uk" (domain being made up).
Outlook shows an archive named " Archive - Fred.Smith#domain.co.uk" where Outlook automatically moves emails after a certain period.
Current code:
Set olRecip = olNS.CreateRecipient("Archive - Fred.Smith#domain.co.uk")
olRecip.Resolve
Set olFolder = olNS.GetSharedDefaultFolder(olRecip, olFolderInbox)
This opens the main inbox. How do I select the archive folder?
"Archive" folder is usually at the root level - like inbox
in that case:
Sub ArchiveItems()
' Moves each of the selected items on the screen to an Archive folder.
Dim olApp As New Outlook.Application
Dim olExp As Outlook.Explorer
Dim olSel As Outlook.Selection
Dim olNameSpace As Outlook.NameSpace
Dim olArchive As Outlook.Folder
Dim intItem As Integer
Set olExp = olApp.ActiveExplorer
Set olSel = olExp.Selection
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArchive = olNameSpace.Folders("myMail#mail.com").Folders("Archive")
For intItem = 1 To olSel.Count
olSel.Item(intItem).Move olArchive
Next intItem
End Sub
to get Inbox you could use default access:
Dim olInbox As Outlook.Folder
Set olInbox = olNameSpace.GetDefaultFolder(olFolderInbox)
Note - This will get you the default Inbox folder, if you have a few accounts in outlook you should verify it's really the folder you want - or use the mail specific approach like in Archive folder above
For Debugging - if you want to check all available subfolders
For i = 1 To olInbox.Folders.Count
Debug.Print olInbox.Folders(i).Name
Next i
Should be
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk")
Full Example
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
Set olNs = Application.Session
Dim ARCHIVE_FOLDER As Outlook.MAPIFolder
Set ARCHIVE_FOLDER = olNs.Folders("Archive - Fred.Smith#domain.co.uk") _
.Folders("Inbox")
Debug.Print ARCHIVE_FOLDER.Name
Debug.Print ARCHIVE_FOLDER.FolderPath
Debug.Print ARCHIVE_FOLDER.Store.DisplayName
ARCHIVE_FOLDER.Display
Set Items = ARCHIVE_FOLDER.Items
For i = Items.Count To 1 Step -1
DoEvents
Debug.Print Items(i).Subject
Next
End Sub
MAPIFolder Object

Outlook 2013 VBA display Shared Calendar

I've got some VBa code that opens the Calendar in a new window, but I now need it to display the shared calendars that I've already got setup, but the only code I can find Creates a new shared calendar in the new window i've just created;
Sub DispCalendars()
Dim myOlApp As Outlook.Application
Dim myNms As Outlook.NameSpace
Dim myFolder As Outlook.MAPIFolder
Dim myRecipient As Outlook.Recipient
Dim myExplorer As Outlook.Explorer
Dim SharedFolder As Outlook.MAPIFolder
Set myOlApp = CreateObject("Outlook.Application")
Set myNms = myOlApp.GetNamespace("MAPI")
Set myFolder = myNms.GetDefaultFolder(olFolderCalendar)
Set myExplorer = myOlApp.ActiveExplorer
Set myExplorer.CurrentFolder = myFolder
Set myRecipient = myNms.CreateRecipient("Bob the Builder")
Set SharedFolder = myNms.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
myExplorer.SelectFolder SharedFolder
End Sub
If I change to 'myRecipient' part to just a name, it errors and I can't seem to work it out.
Here is something how it looks (when I do it manually) and I would like to recreate it in code.
I think you miss the line to show the Folder selected in Outlook
myExplorer.CurrentFolder = SharedFolder
i guess instead of the "selectfolder"-line... also some of the other lines could be deleted, espacially
Set myExplorer.CurrentFolder = myFolder
as it does not make sende to open two Folders one after another in one Sub.
Yours
Max

Set custom value when item moved to folder in outlook

I'm looking to set a Date on a field anytime an email is moved into a specific folder.
the field is custom called "Completed Date".
Could I get a little help on VBA code to set a custom field (date) when an item is moved into a folder (folder name is "Completed").
I'm ultimately looking to report on the time an item (custom form email) was received to the time it was completed (as per the action of moving the email to a completed folder.
Very rudimentary ticketing system, I'm very aware :) .
thanks,
A
Use ItemAdd http://www.outlookcode.com/article.aspx?id=62 where you reference the "Completed" folder.
Combine it with code like this http://www.vbaexpress.com/forum/showthread.php?5738-Need-to-Add-a-Userdefined-Property-to-Mail-Items
SAMPLE CODE
Change it so you do not update all items in the folder just the one item that triggered ItemAdd.
Option Explicit
Sub AddAUserDefinedProperty()
Dim olApplication As Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim olItem As Object
Dim strDomain As String
Dim olProperty As Outlook.UserProperty
Set olApplication = New Outlook.Application
Set olNameSpace = olApplication.GetNamespace("Mapi")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderJunk)
For Each olItem In olFolder.Items
strDomain = Mid(olItem.SenderEmailAddress, _
InStr(1, olItem.SenderEmailAddress, "#") + 1)
Set olProperty = olItem.UserProperties.Add("Domain", olText)
olProperty.Value = strDomain
Debug.Print olItem.SenderEmailAddress, olProperty.Value
olItem.Save
Next olItem
Set olApplication = Nothing
Set olNameSpace = Nothing
Set olFolder = Nothing
Set olProperty = Nothing
End Sub
Even more reference material here http://www.codeproject.com/Articles/427913/Using-User-Defined-Fields-in-Outlook

Loop Through PSTs in Outlook 2003 with VBA

In Outlook 2007, I am able to loop through mails stores, including PSTs, using code like this:
Dim stores As Outlook.stores
Set stores = objNamespace.stores
Dim store As Outlook.store
For Each store In stores
MsgBox store.FilePath
Next
However, in Outlook 2003, the Outlook.store and Outlook.stores objects do not exist.
Are there equivalent objects in Outlook 2003?
What other method might I use to loop through mail stores?
Thank you.
This sample code for Outlook 2003 will loop through the high level mailboxes and print certain properties to the Immediate Window. I chose the properties that looked most useful based on your request.
Sub LoopThruMailboxes()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim mailboxCount As Long
Dim i As Long
Dim folder As Outlook.MAPIFolder
' get local namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
mailboxCount = olNS.Folders.count
For i = 1 To mailboxCount
Set folder = olNS.Folders(i)
Debug.Print folder.EntryID
Debug.Print folder.StoreID
Debug.Print folder.Name
Debug.Print folder.FolderPath
Next i
End Sub
folder.Name is the name of the mailbox, folder.StoreID is the store ID (I'm not sure what you meant by "store file path", I didn't see anything that looked relevant anyway).
Here's a functionized version that returns folder name and store ID as an array, which you could assign directly to a listbox:
Function GetMailBoxInfo() As String()
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim mailboxCount As Long
Dim i As Long
Dim folder As Outlook.MAPIFolder
Dim tempString() As String
' get local namespace
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
mailboxCount = olNS.Folders.count
' size array accordingly
ReDim tempString(1 To mailboxCount, 1 To 2)
For i = 1 To mailboxCount
Set folder = olNS.Folders(i)
tempString(i, 1) = folder.Name
tempString(i, 2) = folder.StoreID
Next i
GetMailBoxInfo = tempString
End Function
ex:
ListBox1.List = GetMailBoxInfo