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

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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Regardless of which version on MS Access you are using, one of the harder data-entry forms to create is one where most data from previous entries needs to be appended to new records, especially when there are numerous fields and records involved.  W…
I see at least one EE question a week that pertains to using temporary tables in MS Access.  But surprisingly, I was unable to find a single article devoted solely to this topic. I don’t intend to describe all of the uses of temporary tables in t…
Using Microsoft Access, learn some simple rules for how to construct tables in a relational database. Split up all multi-value fields into single values: Split up fields that belong to other things into separate tables: Make sure that all record…
In Microsoft Access, learn how to use Dlookup and other domain aggregate functions and one method of specifying a string value within a string. Specify the first argument, which is the expression to be returned: Specify the second argument, which …

911 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

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now