Create a query dynamically for every subfolder in an exchange mailbox

Posted on 2006-11-27
Last Modified: 2008-02-01
We have an exchange server mailbox that we track workflow out of.  A webform creates an email message into this mailbox.  Once there 1 of houndreds of people have rights to move this message around, placing it in subfolder upon subfolder.  I have manually linked over 250 mailbox subfolders using Access. I then created a vb function to create 1 MT query and 249 append queries based on the linked tables.  The problem comes in that any one of those houdreds of people have the ability to create a subfolder, at that point I lose visibility of the messages.

What I am looking for is a way to dynamically link to all folders in an exchange server mailbox, then create an append query for each linked table, then run it.
Question by:orbitus
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions

Accepted Solution

orbitus earned 0 total points
ID: 18084818
ok, I found everything I needed from EE so I feel I should post the answer here as well. You need to link a table to an exchange folder and then make a table from that to put your messages in. Most people wont have a 13 digit unique identifying number so you can just delete that part. Hope this helps someone.

I activate the sub with...
ImportItems "Mailbox - GPM Job Request", "DMTable"

That kicks off...

Sub ImportItems(strMailBox As String, strTableToGo As String)
    Dim u, v, w, x, y, z
    Set PublicFolder = ol.GetNamespace("MAPI").Folders(strMailBox)
    DoCmd.SetWarnings False
    For u = 1 To PublicFolder.Folders.Count
        If PublicFolder.Folders.Item(u).DefaultItemType = olMailItem Then
            connectExchange strMailBox, PublicFolder.Folders.Item(u).Name, Replace(Replace(Replace(PublicFolder.Folders.Item(u).FolderPath, "Mailbox - GPM Job Request", "GPMJR"), "To be Processed by GPMA", "TbPbGPMA"), "Forwarded to Data Mgt", "FTDM"), PublicFolder.Folders.Item(u).FolderPath, 1, strTableToGo
            SysCmd acSysCmdSetStatus, PublicFolder.Folders.Item(u).Name & " : done!"
            '*** Now subfolder Level 1
            For v = 1 To PublicFolder.Folders.Item(u).Folders.Count
                If PublicFolder.Folders.Item(u).Folders.Item(v).DefaultItemType = olMailItem Then
                    connectExchange strMailBox, PublicFolder.Folders.Item(u).Folders.Item(v).Name, Replace(Replace(Replace(PublicFolder.Folders.Item(u).Folders.Item(v).FolderPath, "Mailbox - GPM Job Request", "GPMJR"), "To be Processed by GPMA", "TbPbGPMA"), "Forwarded to Data Mgt", "FTDM"), PublicFolder.Folders.Item(u).FolderPath, 2, strTableToGo
                    SysCmd acSysCmdSetStatus, PublicFolder.Folders.Item(u).Folders.Item(v).Name & " : done!"
            '*** Now subfolder Level 2
                    For w = 1 To PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Count
                        If PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).DefaultItemType = olMailItem Then
                            connectExchange strMailBox, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Name, Replace(Replace(Replace(PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).FolderPath, "Mailbox - GPM Job Request", "GPMJR"), "To be Processed by GPMA", "TbPbGPMA"), "Forwarded to Data Mgt", "FTDM"), PublicFolder.Folders.Item(u).Folders.Item(v).FolderPath, 2, strTableToGo
                            SysCmd acSysCmdSetStatus, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Name & " : done!"
                    '*** Now subfolder Level 3
                            For x = 1 To PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Count
                                If PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).DefaultItemType = olMailItem Then
                                    connectExchange strMailBox, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Name, Replace(Replace(Replace(PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).FolderPath, "Mailbox - GPM Job Request", "GPMJR"), "To be Processed by GPMA", "TbPbGPMA"), "Forwarded to Data Mgt", "FTDM"), PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).FolderPath, 2, strTableToGo
                                    SysCmd acSysCmdSetStatus, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Name & " : done!"
                            '*** Now subfolder Level 4
                                    For y = 1 To PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Count
                                        If PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).DefaultItemType = olMailItem Then
                                            connectExchange strMailBox, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).Name, Replace(Replace(Replace(PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).FolderPath, "Mailbox - GPM Job Request", "GPMJR"), "To be Processed by GPMA", "TbPbGPMA"), "Forwarded to Data Mgt", "FTDM"), PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).FolderPath, 2, strTableToGo
                                            SysCmd acSysCmdSetStatus, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).Name & " : done!"
                                    '*** Now subfolder Level 5
                                            For z = 1 To PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).Folders.Count
                                                If PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).Folders.Item(z).DefaultItemType = olMailItem Then
                                                    connectExchange strMailBox, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).Folders.Item(z).Name, Replace(Replace(Replace(PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).Folders.Item(z).FolderPath, "Mailbox - GPM Job Request", "GPMJR"), "To be Processed by GPMA", "TbPbGPMA"), "Forwarded to Data Mgt", "FTDM"), PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).FolderPath, 2, strTableToGo
                                                    SysCmd acSysCmdSetStatus, PublicFolder.Folders.Item(u).Folders.Item(v).Folders.Item(w).Folders.Item(x).Folders.Item(y).Folders.Item(z).Name & " : done!"
                                                End If   ' Subfolder level 5
                                            Next z       ' Subfolder level 5
                                        End If   ' Subfolder level 4
                                    Next y       ' Subfolder level 4
                                End If   ' Subfolder level 3
                            Next x       ' Subfolder level 3
                        End If   ' Subfolder level 2
                    Next w       ' Subfolder level 2
                End If  ' Subfolder level 1
            Next v      ' Subfolder level 1
        End If  ' Folder Top Level
    Next u      ' Folder Top Level
    DoCmd.SetWarnings True
    SysCmd acSysCmdSetStatus, "All done with " & strMailBox & "!!"
    Set PublicFolder = Nothing
End Sub

This kicks off another sub for each mail subfolder in that mailbox.

Sub connectExchange(strMailBox As String, strFolder As String, strTableName As String, _
                    strFullTableName As String, intSubFolder As Integer, strTableToGo As String)
    Dim cnn1 As ADODB.Connection
    Dim cmdExeproc As ADODB.Command
    Dim rstRecords As ADODB.Recordset
    Dim strcnn As String
    Dim strMailLevelBox As String
    strMailLevelBox = Mid(strFullTableName, 3)
    strMailLevelBox = Replace(strMailLevelBox, "\", "|", 1, 1)
    Dim varTest As Variant
    On Error GoTo DeleteErr
    Set cnn1 = New ADODB.Connection
    Select Case intSubFolder
        Case 1
            strcnn = "Provider=Microsoft.JET.OLEDB.4.0;Exchange 4.0;MAPILEVEL=" & strMailBox & "|;PROFILE=Outlook;TABLETYPE=0;DATABASE=C:\DOCUME~1\cgk0o7\LOCALS~1\Temp\;TABLENAME=" & strFolder & ";"
        Case 2
            strcnn = "Provider=Microsoft.JET.OLEDB.4.0;Exchange 4.0;MAPILEVEL=" & strMailLevelBox & ";PROFILE=Outlook;TABLETYPE=0;DATABASE=C:\DOCUME~1\cgk0o7\LOCALS~1\Temp\;"   'TABLENAME=" & strFolder & ";"
'        Case 3
'            'strMailLevelBox = Replace(strMailLevelBox, "|", "\", 35)
'            strcnn = "Provider=Microsoft.JET.OLEDB.4.0;Exchange 4.0;MAPILEVEL=" & strMailLevelBox & ";PROFILE=Outlook;TABLETYPE=0;DATABASE=C:\DOCUME~1\cgk0o7\LOCALS~1\Temp\;"   'TABLENAME=" & strFolder & ";"
    End Select
    cnn1.Open strcnn
    cnn1.CursorLocation = adUseClient
    Set cmdExeproc = New ADODB.Command
    cmdExeproc.ActiveConnection = cnn1
    cmdExeproc.CommandText = "SELECT * FROM [" & strFolder & "]"
    'Set cmdExeproc.ActiveConnection = cnn1
    'Set rstRecords = cmdExeproc.Execute
    'cmdExeproc.ActiveConnection = Nothing
    Set rstRecords = New ADODB.Recordset
    rstRecords.CursorLocation = adUseClient
    rstRecords.Open cmdExeproc, , adOpenKeyset, adLockReadOnly
            Dim db2 As Database
        'Dim rst As Recordset
        Dim tdfNew As TableDef
        Dim fldNew As Field
        Dim strNew As String
        Dim dbType As DAO.Field
    If rstRecords.EOF = True And rstRecords.BOF = True Then
        SysCmd acSysCmdSetStatus, strFolder & " is empty"
       Exit Sub
       'varTest = rstRecords.GetRows()

        Set db2 = CurrentDb
        'Set rst = db2.OpenRecordset("SourceTable")
        DeleteTableAndRelation strTableName
        Set tdfNew = db2.CreateTableDef(strTableName)
           For x = 0 To rstRecords.Fields.Count - 1
               strNew = rstRecords.Fields.Item(x).Name
               Set dbType = New DAO.Field
               Select Case rstRecords.Fields.Item(x).Type
                    Case adVarWChar
                        dbType.Type = dbText
                    Case adLongVarWChar
                        dbType.Type = dbMemo
                    Case adInteger
                        dbType.Type = dbLong
                    Case adDate
                        dbType.Type = dbDate
                    Case adBoolean
                        dbType.Type = dbBoolean
                    Case Else
                        MsgBox "Unknown ADO Data Type"
                        dbType.Type = dbMemo
               End Select
               Set fldNew = tdfNew.CreateField(strNew, dbType.Type, rstRecords.Fields.Item(x).DefinedSize)
               tdfNew.Fields.Append fldNew
               Set fldNew = Nothing
           Next x
        db2.TableDefs.Append tdfNew
        Dim rst As ADODB.Recordset
        Dim fld As ADODB.Field
        'first clear out any old data in the temp table
        CurrentDb.Execute "DELETE * FROM [" & strTableName & "];"
        'now open a recordset of that table so you can add new records
        Set rst = New ADODB.Recordset
        rst.Open Source:="SELECT * FROM [" & strTableName & "];", _
                 ActiveConnection:=CurrentProject.Connection, _
                 CursorType:=adOpenKeyset, _
        'now loop through the recordset you passed in and add
        'each record to the temp table
        'On Error Resume Next
        Do While Not rstRecords.EOF
                For Each fld In rstRecords.Fields
                    If fld.Name = "Message to Me" And IsNull(fld.Value) Then
                        rst.Fields(fld.Name).Value = False
                    ElseIf fld.Name = "Message CC to Me" And IsNull(fld.Value) Then
                        rst.Fields(fld.Name).Value = False
                        rst.Fields(fld.Name).Value = fld.Value
                    End If
        Set rst = Nothing
        Set db = Nothing
       'Debug.Print "Got em!"
        DoCmd.RunSQL "INSERT INTO " & strTableToGo & " ( Importance, [Message Class], Priority, Subject, [From], " & _
        "[Message To Me], [Message CC to Me], [Sender Name], CC, [To], Received, [Message Size], Body, " & _
        "[Creation Time], [Last Modification Time], [Subject Prefix], [Has Attachments], [Normalized " & _
        "Subject], [Object Type], [Content Unread], JRFno, Emergency, RapidRefresh, Dept, DueDate, Folder " & _
        ") SELECT [" & strTableName & "].Importance, [" & strTableName & "].[Message Class], [" & strTableName & _
        "].Priority, [" & strTableName & "].Subject, [" & strTableName & "].From, [" & strTableName & _
        "].[Message To Me], [" & strTableName & "].[Message CC to Me], [" & strTableName & _
        "].[Sender Name], [" & strTableName & "].CC, [" & strTableName & "].To, [" & strTableName & _
        "].Received, [" & strTableName & "].[Message Size], [" & strTableName & "].Body, [" & _
        strTableName & "].[Creation Time], [" & strTableName & "].[Last Modification Time], [" & _
        strTableName & "].[Subject Prefix], [" & strTableName & "].[Has Attachments], [" & strTableName & _
        "].[Normalized Subject], [" & strTableName & "].[Object Type], [" & strTableName & _
        "].[Content Unread], getdigitnumber([subject],13,True,1) AS JRFno, getcomments([Body],'Emergency = ',1) " & _
        "AS Emergency, IIf(InStr([subject],'RAPID')>0,'Y','N') AS RapidRefresh, " & _
        "getcomments([Body],'Department = ',2) AS Dept, getcomments([Body],'Due_Date = ',8) AS " & _
        "DueDate, '" & strFullTableName & "' AS Folder FROM [" & strTableName & "];"
    End If
    Set rstRecords = Nothing
    Set cnn1 = Nothing
    Set cmdExeproc = Nothing

    Exit Sub

    If Err = 3265 Then
        SysCmd acSysCmdSetStatus, "Working on " & strFullTableName
    ElseIf Err = -2147467259 Then
        sSleep (2000)
        SysCmd acSysCmdSetStatus, "Got held up at " & strFolder
        Resume HitEmAgain
        Debug.Print "An unexpected error (" & Err & ") occurred: " & Error(Err)
        MsgBox "An unexpected error (" & Err & ") occurred: " & Error(Err)
    End If
    Resume DeleteExit

End Sub

I used status bar updates to keep the user in the loop.

Featured Post

U.S. Department of Agriculture and Acronis Access

With the new era of mobile computing, smartphones and tablets, wireless communications and cloud services, the USDA sought to take advantage of a mobilized workforce and the blurring lines between personal and corporate computing resources.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Did you know that more than 4 billion data records have been recorded as lost or stolen since 2013? It was a staggering number brought to our attention during last week’s ManageEngine webinar, where attendees received a comprehensive look at the ma…
This article describes a method of delivering Word templates for use in merging Access data to Word documents, that requires no computer knowledge on the part of the recipient -- the templates are saved in table fields, and are extracted and install…
Learn how to number pages in an Access report over each group. Activate two pass printing by referencing the pages property: Add code to the Page Footers OnFormat event to capture the pages as there occur for each group. Use the pages property to …
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

752 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question