Outlook VBA to Replicate 'Sort Subfolders A to Z' in the Folder Pane - vba

Is there a method in VBA to achieve the same effect of right-clicking on a folder in the folder pane and selecting 'Sort Subfolders A to Z'?
As a comparison, the code below from Microsoft.com sorts Items in a folder; however, it does not appear that the .Sort method used in this code is available for the Folders object like it is for the Items object.
Sub SortByDueDate()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItem As Outlook.TaskItem
Dim myItems As Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items
myItems.Sort "[DueDate]", False
For Each myItem In myItems
MsgBox myItem.Subject & "-- " & myItem.DueDate
Next myItem
End Sub
Additionally, it does not appear that there are any methods available for moving folders in the tree.
Is more extensive code required to replicate the native 'Sort Subfolders A to Z' action with VBA?
Can this be achieved with PropertyAssessor and, if so, what is the proper syntax for setting the PR_SORT_POSITION property? For example, the code below results in an error, as commented in the code.
Sub Example()
Dim myProp As String
Dim myValue As Variant
Dim oFolder As Folder
Set oFolder = Application.Session.GetDefaultFolder(olFolderInbox)
myProp = "http://schemas.microsoft.com/mapi/proptag/0x30200102"
myValue = "FD7F"
oFolder.PropertyAssessor.SetProperty myProp, myValue 'Run-time error '438': Object doesn't support this property or method
End Sub

The Outlook object model doesn't provide any property or method to sort folders. You may find the NavigationPane object helpful. See Customizing the Navigation Pane for more information.

You can sort the folders in the Outlook UI by explicitly setting the PR_SORT_POSITION property on each subfolder - see Get folder list ordered as displayed

I posted my code here because this was high in Google results and all other threads were closed
https://answers.microsoft.com/en-us/outlook_com/forum/all/sorting-outlook-subfolders-z-a/9aef727c-510c-49e0-869d-4234373b71d7
https://answers.microsoft.com/en-us/outlook_com/forum/all/sort-order-of-subfolders/a3b55181-4f5a-43c1-82b3-94eb68a8407b
I've made custom VBA code to sort subfolders Z-A - it will load the folder order [unfortunately you still need to order it A-Z within outlook] and then reverse it so it is Z-A
I needed to quickly adjust a tonne of folders and couldn't find any code anywhere, so I quickly made the below to help patch the issue.
I didn't have the time to write lots of detail about how it works.
Known issues with the code:
It doesn't always sort the first folder. No idea why.
It doesn't seem to like it when you're looking at the list of subfolders - minimise it then run the code
This code is used to reverse the sorting of subfolders under Inbox, you'll need to adjust as required.
Sub sortZA()
Dim email_name: email_name = "email#emails.com" 'write the name of the mailbox as it appears in outlook
Dim objMainFolder As Outlook.Folder
Dim Folders As Outlook.Folders
Dim Folderx As Outlook.Folder
Dim sort_order, sort_order_b, arr
Set arr = CreateObject("System.Collections.ArrayList")
Set arr_sorted = CreateObject("System.Collections.ArrayList")
dim found_folder: found_folder=0
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
If LCase(Folderx.Name) = LCase(email_name) Then
Set objMainFolder = Folderx.Folders("Inbox") 'adjust as required. Add more folders via .folders("name")
found_folder=1
End If
Next
if found_folder =0 then
msgbox "the email folder with the name '" & email_name & "' was not found"
exit sub
end if
Dim reloadFolder As Outlook.Folder
Dim propertyAccessor As Outlook.propertyAccessor
For Each Folderx In objMainFolder.Folders
' if there is an error, then there might not be any order data. Try reordering them manually. Also make sure loading the email as the main profile instead of as an additional mailbox.
'On Error Resume Next
Set propertyAccessor = Folderx.propertyAccessor
sort_order = propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30200102"))
arr.Add Folderx.Name & "##~~##" & sort_order
arr_sorted.Add Folderx.Name & "##~~##" & sort_order
Next
arr.Sort 'keep A-Z (the original list from outlook isn't in A-Z order)
arr_sorted.Sort 'make A-Z
arr_sorted.Reverse 'make Z-A
Dim t, a, b, i, t2, a2, b2
i = 0
For Each arr_folder In arr
t = Split(arr_folder, "##~~##")
a = t(0) 'which folder name?
b = t(1) 'what is the original order? [should already be A-Z]
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
'On Error Resume Next
If LCase(Folderx.Name) = LCase(email_name) Then
Set reloadFolder = Folderx.Folders("Inbox").Folders(a)
End If
Next
t2 = Split(arr_sorted(i), "##~~##")
a2 = t2(0) 'which folder name?
b2 = t2(1) 'what is the reversed order?
Set propertyAccessor = reloadFolder.propertyAccessor
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(b2)
i = i + 1
Next
End Sub
Additional Notes: I did try experimenting with applying ordering data manually. I couldn't get it to work properly. All the binary converting code wasn't producing the correct values, and I ended up using HEX(). Here is an example of what I was doing:
Dim custom_order As Long
custom_order = 15
For Each arr_folder In arr
'the array only contains a list of folder names.. we need to load the folder in outlook to process it again. The below line of code loads the main email inbox, then the subfolder from the array [different from the above code]
Set reloadFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders(arr_folder)
Set propertyAccessor = reloadFolder.propertyAccessor
hexval = Hex(custom_order)
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(hexval)
custom_order = custom_order + 1
Next
End Sub

Related

Is there a way to compare all the titles of all Rss feeds and delete duplicates? [duplicate]

This question already has answers here:
How can I compare all the titles of all RSS feeds and delete duplicates?
(2 answers)
Closed 5 years ago.
I'm wondering if there is a way to compare ALL TITLES in ALL RSS FEEDS and delete the duplicates.
I read through a lot of RSS Feeds, and it's obvious that a lot of people cross-post to several forums, and then I end up seeing the same RSS Feed multiple times.
I really just want to see each one one single time. Is there a way to list all feeds, and delete duplicates, if I actually have duplicates in my entire MS Outlook RSS Feed list?
Here's 0m3r's script, modified slightly.
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Dim Item As Object
Dim Items As Items
Dim DupItem As Object
Dim i As Long
Dim j As Long
For j = 1 To 21
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds).Folders(j)
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = RSS_Folder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.Subject) Then
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
Item.Delete
Else
'Debug.Print Item.Subject
DupItem.Add Item.Subject, 0
End If
End If
Next i
Debug.Print RSS_Folder
Next j
Set olNs = Nothing
Set RSS_Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
Iterating over all items in the folder is not really a good idea.
For Each myItem In subFolder.Items
If InStr(myItem.Subject, "[on hold]") > 0 Then
You can use the Find/FindNext or Restrict methods of the Items class to find all items that correspond to your conditions. Read more about them 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
Also you may find the AdvancedSearch method of the Application class helpful.
The key benefits of using the AdvancedSearch method in Outlook are:
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).
Finally, you can stop the search process at any moment using the Stop method of the Search class.
Read more about that in the Advanced search in Outlook programmatically: C#, VB.NET article.
Work with Dictionary Object to compare Items.Subject in your olFolderRssFeeds
Dictionary in VBA is a collection-object:
you can store all kinds of things in it: numbers, texts, dates, arrays, ranges, variables and objects, Every item in a Dictionary gets its own unique key and
With that key you can get direct access to the item (reading/writing).
Here is quick Example code
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Dim Item As Object
Dim Items As Items
Dim DupItem As Object
Dim i As Long
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds) _
.Folders("Microsoft At Home")
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = RSS_Folder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.subject) Then
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
' Item.Delete
Else
DupItem.Add Item.subject, 0
End If
End If
Next i
Set olNs = Nothing
Set RSS_Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
This Example shows how to process all Folders under RSS Feed Folders
Option Explicit
Public Sub DupeRSS()
Dim olNs As Outlook.NameSpace
Dim RSS_Folder As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set RSS_Folder = olNs.GetDefaultFolder(olFolderRssFeeds)
' // Process Current Folder
Example RSS_Folder
End Sub
Public Sub Example(ByVal ParentFolder As Outlook.MAPIFolder)
Dim Folder As Outlook.MAPIFolder
Dim Item As Object
Dim DupItem As Object
Dim Items As Items
Dim i As Long
Set DupItem = CreateObject("Scripting.Dictionary")
Set Items = ParentFolder.Items
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is PostItem Then
Set Item = Items(i)
If DupItem.Exists(Item.subject) Then
Debug.Print Item.subject ' Print on Immediate Window
Debug.Print TypeName(Item) ' Print on Immediate Window
Item.Delete
Else
DupItem.Add Item.subject, 0
End If
End If
Next i
' // Recurse through subfolders
If ParentFolder.Folders.Count > 0 Then
For Each Folder In ParentFolder.Folders
Example Folder
Debug.Print Folder.Name
Next
End If
Set Folder = Nothing
Set Item = Nothing
Set Items = Nothing
Set DupItem = Nothing
End Sub
Remember the code will only compare duplicate in single folder

Searching Outlook email (and replying to it) using Excel VBA

I want to search ALL my outlook for latest message in a conversation (I use Subject name as search key).
This latest message can be in Inbox, Sent Items, in a sub folder of Inbox, a sub-sub folder of Inbox (anywhere).
I can achieve this by some very tedious code, going through every level of each major folder, but not only this method is very messy, I can't determine if this found message is the latest in this conversation.
I have the following code, which
--> Searches Inbox for "searchKey"
--> If finds it in Inbox folder, replies to it
--> If not, it moves into subfolders of Inbox, and continues the same process
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olFldr As MAPIFolder
Dim olMail ' As Outlook.MailItem
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set olFldr = Fldr
tryAgain:
For Each olMail In olFldr.Items
If InStr(olMail.Subject, searchKey) <> 0 Then
Set ReplyAll = olMail.ReplyAll
With ReplyAll
.HTMLBody = Msg & .HTMLBody
emailReady = True
.Display
End With
End If
Next olMail
If Not emailReady Then
i = i + 1
If i > Fldr.Folders.Count Then
MsgBox ("The email with the given subject line was not found!")
Exit Sub
Else
Set olFldr = Fldr.Folders(i)
GoTo tryAgain
End If
End If
This code might be confusing and long, so please let me know if you need any clarification.
The question is: How can I search through ALL Outlook, without going manually through every folder/subfolder/sub-subfolder... without this method, and find the LAST message in a specific conversation? Or, at least, how can I optimize this code so I don't miss any folder, and know the dates and times these emails were sent?
You can use the built in AdvancedSearch function, which returns a Search object containing items.
These should have date properties, so you only need your code to go through the search object mailItems and find that with the latest date ( ReceivedTime)?
I would suggest using the bottom example on that page - it gets a table object from the search, and then you use
Set MyTable = MySearch.GetTable
Do Until MyTable.EndOfTable
Set nextRow = MyTable.GetNextRow()
Debug.Print nextRow("ReceivedTime")
Loop
From there, you can do the comparison to find the latest time, and if you want to do something with the mailitem you would need to obtain the "EntryID" column from the table.
Then use the GetItemFromID method of the NameSpace object to obtain a full item, since the table returns readonly objects.
You can also apply a date filter to the search if you wish, if you knew a minimum date for instance.
To go through all folders do this:
Go once through all the primary folders in Outlook and then for each major folder go through each subfolder. If you have more branches then is guess you have to add more levels to the code "for each Folder3 in folder2.folders". Also in the if clause you can test the date of the mail and go from the newest to the oldest. Set oMsg.display to see what mail is being checked
Public Sub FORWARD_Mail_STAT_IN()
Dim Session As Outlook.NameSpace
Dim oOutLookObject As New Outlook.Application
Dim olNameSpace As NameSpace
Dim oItem As Object
Dim oMsg As Object
Dim searchkey As String
Set oOutLookObject = CreateObject("Outlook.Application")
Set oItem = oOutLookObject.CreateItem(0)
Set olNameSpace = oOutLookObject.GetNamespace("MAPI")
Set Session = Application.Session
Set Folders = Session.Folders
For Each Folder In Folders 'main folders in Outlook
xxx = Folder.Name
For Each Folder2 In Folder.Folders 'all the subfolders from a main folder
yyy = Folder2.Name
Set oFolder = olNameSpace.Folders(xxx).Folders(yyy) 'in each folder we search all the emails
For Z = oFolder.Items.Count To 1 Step -1 ' For Z = 1 To oFolder.Items.Count
With oFolder.Items(Z)
Set oMsg = oFolder.Items(Z)
If Format(oMsg.SentOn, "mm/dd/yyyy") = Format(Date, "mm/dd/yyyy") And InStr(1, LCase(oMsg.Subject), searchkey, vbTextCompare) > 0 Then
oMsg.display
' insert code
End If
End With
Next Z
Next Folder2
Next Folder

VBA, MS Outlook, Folder Item

I want to implement an VBA application, which uses the selected object (E-mail, task, folder).
My try with Application.ActiveExplorer.Selection.Item(i_item) seems to return only mails, tasks, calender entries or notes but never an folder (e.g. 'Inbox\').
When the user selects an e-mail, and then starts the VBA macro, the solution Application.ActiveExplorer.Selection.Item(i_item) delivers the desired results.
However, if the last item picked by the Outlook user was an folder (e.g. 'Sent Mails'). And the VBA makro started afterward, than the macro should recive the Folder Item (without additional user interaction). This is currently not the case. The code above still delivers the e-mail, or task.
How do I check, if the last selection was on an folder (not an e-mail, etc)?
How do I access the Folder item?
If this is not possible I will switch back to Pickfolder (like proposd by Darren Bartrup-Cook) but this is not me prefred solution.
I want to get the selected folder in order to change its icon, so our code is somehow the same.
I noticed that Application.ActiveExplorer.Selection.Item(i_item) it is not perfect, since it throws an exception for empty folders or on calendar etc.
So I use Application.ActiveExplorer.CurrentFolder.DefaultMessageClass (Application.ActiveExplorer.NavigationPane.CurrentModule.Name or Application.ActiveExplorer.NavigationPane.CurrentModule.NavigationModuleType) in order to figure out where I actually am.
By that approach it is easy to get current selected folder
Dim folder As Outlook.MAPIFolder
Dim folderPath As String, currItemType As String
Dim i As Integer
currItemType = Application.ActiveExplorer.CurrentFolder.DefaultMessageClass
If currItemType = "IPM.Note" Then 'mail Item types https://msdn.microsoft.com/en-us/library/office/ff861573.aspx
Set folder = Application.ActiveExplorer.CurrentFolder
folderPath = folder.Name
Do Until folder.Parent = "Mapi"
Set folder = folder.Parent
folderPath = folder.Name & "\" & folderPath
Loop
Debug.Print folderPath
End If
haven't got an problem with it yet. In your case, you can store the selection in a global variable, so you always know which folder was selected last.
This procedure will ask you to select the folder.
If you interrupt the code and examine the mFolderSelected or MySelectedFolder then you should be able to work something out:
Public Sub Test()
Dim MySelectedFolder As Variant
Set MySelectedFolder = PickFolder
End Sub
Public Function PickFolder() As Object
Dim oOutlook As Object 'Outlook.Application
Dim nNameSpace As Object 'Outlook.Namespace
Dim mFolderSelected As Object 'Outlook.MAPIFolder
On Error GoTo ERROR_HANDLER
Set oOutlook = CreateObject("Outlook.Application")
Set nNameSpace = oOutlook.GetNameSpace("MAPI")
Set mFolderSelected = nNameSpace.PickFolder
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'The commented out code will return only email folders. '
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If Not mFolderSelected Is Nothing Then
' If mFolderSelected.DefaultItemType = 0 Then
Set PickFolder = mFolderSelected
' Else
' Set PickFolder = Nothing
' End If
Else
Set PickFolder = Nothing
End If
Set nNameSpace = Nothing
Set oOutlook = Nothing
On Error GoTo 0
Exit Function
ERROR_HANDLER:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & vbCr & _
" (" & Err.Description & ") in procedure PickFolder."
Err.Clear
End Select
End Function
NB: This was written to be used in Excel and has late binding - you'll need to update it to work in Outlook (no need to reference Outlook for a start).

For Each loop: Some items get skipped when looping through Outlook mailbox to delete items

I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub

Find and Select an Outlook Email from MS Access

I need to build a tool that will allow the user to select an email from his Outlook so I can then save that email as a .msg file or alternately save just the attachment as a file.
I'm stumbling a little bit over what might be the easiest and the best way to allow searching/filtering of emails. I need to give the user a view that is at least slightly similar to Outlook (for example, folders should be the same order/hierarchy.
Does the Outlook Object Model have some kind of Explorer/Picker/Selection dialog I can call that will return a storeid and an entryid after the user selects an email? Or do I need to roll my own?
I should mention that I already know how to save the email or attachment so my question is only about handling selection and filtering of emails.
FYI, I'm programming this in MS Access 2007 with Outlook 2007. The target machines have either 2007 or 2010 versions of Access and Outlook.
Linking to the Outlook table is fine. The problem is that Outlook doesn't provide a unique ID to each message and if the message is moved from one folder to another, its ID changes. Clearly not designed by someone who understands databases.
A better approach may be to create an Outlook add-in that runs within Outlook, then performs the tasks you need to send the info to Access.
I rarely program with Access but I moved some code across from Outlook, hacked it around a bit and it seems to work. This is not a solution but it should show you how to access all the information you need.
I had one problem. Neither Set OutApp = CreateObject("Outlook.Application") nor Set OutApp = New Outlook.Application create a new instance of Outlook if one is already open. So Quit closes Outlook whether or not it was open before the macro started. I suggest you post a new question on this issue; I am sure someone knows how to tell if Outlook is already open and therefore not to quit it.
The folder structure in Outlook is slightly awkward because the top level folders are of type Folders while all sub-folders are of type MAPIFolder. Once you have got past that it is fairly straightforward.
The code below includes function GetListSortedChildren(ByRef Parent As MAPIFolder) As String. This function finds all the children of Parent and returns a string such as "5,2,7,1,3,6,4" which lists the indices for the children in ascending sequence by name. I would use something like this to populates a ListView by expanding nodes as the user required.
I have provided a subroutine CtrlDsplChld() which controls the output to the immediate windows of all the folders in sequence. I believe that should give you enough guidance to get started on accessing the folder hierarchy.
Subroutine DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long) includes code to find the first message with attachments. This will you tell you how to look through a folder for a particular message.
Finally, CtrlDsplChld() displayes selected properties of the message: Subject, To, HTMLBody and the display names of the attachments.
Hope this helps.
Option Compare Database
Option Explicit
Dim ItemWithMultipleAttachments As Outlook.MailItem
Sub CtrlDsplChld()
Dim ArrChld() As String
Dim ListChld As String
Dim InxAttach As Long
Dim InxChld As Long
Dim InxTopLLCrnt As Long
Dim OutApp As Outlook.Application
Dim TopLvlList As Folders
Set ItemWithMultipleAttachments = Nothing
Set OutApp = CreateObject("Outlook.Application")
'Set OutApp = New Outlook.Application
With OutApp
Set TopLvlList = .GetNamespace("MAPI").Folders
For InxTopLLCrnt = 1 To TopLvlList.Count
' Display top level children and their children
Call DsplChld(TopLvlList.Item(InxTopLLCrnt), 0)
Next
If Not ItemWithMultipleAttachments Is Nothing Then
With ItemWithMultipleAttachments
Debug.Print .Subject
Debug.Print .HTMLBody
Debug.Print .To
For InxAttach = 1 To .Attachments.Count
Debug.Print .Attachments(InxAttach).DisplayName
Next
End With
End If
.Quit
End With
Set OutApp = Nothing
End Sub
Sub DsplChld(ByRef Parent As MAPIFolder, ByVal Level As Long)
Dim ArrChld() As String
Dim InxChld As Long
Dim InxItemCrnt As Long
Dim ListChld As String
Debug.Print Space(Level * 2) & Parent.Name
If ItemWithMultipleAttachments Is Nothing Then
' Look down this folder for a mail item with an attachment
For InxItemCrnt = 1 To Parent.Items.Count
With Parent.Items(InxItemCrnt)
If .Class = olMail Then
If .Attachments.Count > 1 Then
Set ItemWithMultipleAttachments = Parent.Items(InxItemCrnt)
Exit For
End If
End If
End With
Next
End If
ListChld = GetListSortedChildren(Parent)
If ListChld <> "" Then
' Parent has children
ArrChld = Split(ListChld, ",")
For InxChld = LBound(ArrChld) To UBound(ArrChld)
Call DsplChld(Parent.Folders(ArrChld(InxChld)), Level + 1)
Next
End If
End Sub
Function GetListSortedChildren(ByRef Parent As MAPIFolder) As String
' The function returns "" if Parent has no children.
' If the folder has children, the functions returns "P,Q,R, ..." where
' P, Q, R and so on indices of the children of Parent in ascending
' order by name.
Dim ArrInxFolder() As Long
'Dim ArrFolder() As MAPIFolder
Dim InxChldCrnt As Long
Dim InxName As Long
Dim ListChld As String
If Parent.Folders.Count = 0 Then
' No children
GetListSortedChildren = ""
Else
'ReDim ArrName(1 To Parent.Folders.Count)
'For InxChldCrnt = 1 To Parent.Folders.Count
' ArrFolder(InxChldCrnt) = Parent.Folders(InxChldCrnt)
'Next
Call SimpleSortMAPIFolders(Parent, ArrInxFolder)
ListChld = CStr(ArrInxFolder(1))
For InxChldCrnt = 2 To Parent.Folders.Count
ListChld = ListChld & "," & CStr(ArrInxFolder(InxChldCrnt))
Next
GetListSortedChildren = ListChld
End If
End Function
Sub SimpleSortMAPIFolders(ArrFolder As MAPIFolder, _
ByRef InxArray() As Long)
' On exit InxArray contains the indices into ArrFolder sequenced by
' ascending name. The sort is performed by repeated passes of the list
' of indices that swap adjacent entries if the higher come first.
' Not an efficient sort but adequate for short lists.
Dim InxIACrnt As Long
Dim InxIALast As Long
Dim NoSwap As Boolean
Dim TempInt As Long
ReDim InxArray(1 To ArrFolder.Folders.Count) ' One entry per sub folder
' Fill array with indices
For InxIACrnt = 1 To UBound(InxArray)
InxArray(InxIACrnt) = InxIACrnt
Next
If ArrFolder.Folders.Count = 1 Then
' One entry list already sorted
Exit Sub
End If
' Each repeat of the loop moves the folder with the highest name
' to the end of the list. Each repeat checks one less entry.
' Each repeats partially sorts the leading entries and may result
' in the list being sorted before all loops have been performed.
For InxIALast = UBound(InxArray) To 1 Step -1
NoSwap = True
For InxIACrnt = 1 To InxIALast - 1
If ArrFolder.Folders(InxArray(InxIACrnt)).Name > _
ArrFolder.Folders(InxArray(InxIACrnt + 1)).Name Then
NoSwap = False
' Move higher entry one slot towards the end
TempInt = InxArray(InxIACrnt)
InxArray(InxIACrnt) = InxArray(InxIACrnt + 1)
InxArray(InxIACrnt + 1) = TempInt
End If
Next
If NoSwap Then
Exit For
End If
Next
End Sub