Here’s some code that is the start of a library to work with Outlook’s folders. It’s based on some code samples from the web, refactored into something resembling a library.
The best feature is the function OLGetSubFolder, which returns a MAPI folder object for a given path. Totally useful.
I don’t really understand why the first folder is under folders.Item(1), but the sample code used that, so I’m calling that the root folder. Maybe there are folders above that, and this is wrong.
Also featured in this code are a function to test for the existence of an object, and create folders.
Option Compare Database Public Sub test() Dim foldroot As Outlook.MAPIFolder Dim foldr As Outlook.MAPIFolder Dim newfolder As Outlook.MAPIFolder Set foldroot = OLGetRootUserFolder() Set foldr = OLGetSubFolder(foldroot, "\Contacts") Set foldr = OLMakeFolder(foldr, "Lists") Set newfolder = OLMakeFolder(foldr, "Executive Board") Set newfolder = OLMakeFolder(foldr, "Delegates") Set newfolder = OLMakeFolder(foldr, "COPE Board") OLExportQueryToFolder newfolder, "prmCOPEBOARD" Set newfolder = OLMakeFolder(foldr, "Affiliates Offices") End Sub Public Sub OLExportQueryToFolder(folder As Outlook.MAPIFolder, query As String) Dim sFname, sLname, sEmail As String Dim dbs As Database Dim rst As Recordset Set dbs = CurrentDb Set rst = dbs.OpenRecordset(query, dbOpenForwardOnly) While Not rst.EOF If IsNull(rst!Fname) Then sFname = "" Else sFname = rst!Fname If IsNull(rst!Lname) Then sLname = "" Else sLname = rst!Lname If IsNull(rst!email) Then sEmail = "" Else sEmail = rst!email OLInsertContactItem folder, sFname, sLname, sEmail rst.MoveNext Wend End Sub Public Function OLMakeFolder(foldr As Outlook.MAPIFolder, newfolder As String) As Outlook.MAPIFolder Dim f As Outlook.MAPIFolder On Error GoTo FolderDoesNotExist FolderExists: Set f = foldr.folders(newfolder) Set OLMakeFolder = f Exit Function FolderDoesNotExist: Set f = foldr.folders.Add(newfolder) Set OLMakeFolder = f End Function ' based on http://www.programmingmsaccess.c... Public Sub OLInsertContactItem(foldr As Outlook.MAPIFolder, ByVal first As String, ByVal last As String, ByVal email As String) Dim cit1 As Outlook.ContactItem Dim citc1 As Outlook.Items Set cit1 = foldr.Items.Add(olContactItem) With cit1 .FirstName = first .LastName = last .Email1Address = email .Save End With End Sub Private Sub OLDeleteAllInFolder(MAPIFolder As Outlook.MAPIFolder) Dim c As Object Dim i As Outlook.Items Set i = MAPIFolder.Items For Each c In i c.Delete Next End Sub ' based on http://msdn2.microsoft.com/en-us... Private Function OLGetSubFolder(MAPIFolderRoot As Outlook.MAPIFolder, folderPath As String) As Outlook.MAPIFolder Dim returnFolder As Object Dim parts() As String Dim part Set returnFolder = MAPIFolderRoot parts = Split(folderPath, "") For Each part In parts ' Debug.Print "-" & part & "-" If part <> "" Then Set returnFolder = returnFolder.folders.Item(part) End If Next Set OLGetSubFolder = returnFolder End Function Private Function OLGetRootUserFolder() As Outlook.MAPIFolder Dim ola1 As Outlook.Application Dim foldr As Outlook.MAPIFolder Set ola1 = CreateObject("Outlook.Application") Set OLGetRootUserFolder = ola1.GetNamespace("MAPI").folders.Item(1) End Function