Solved

Create a query dynamically for every subfolder in an exchange mailbox

Posted on 2006-11-27
2
402 Views
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.
0
Comment
Question by:orbitus
2 Comments
 
LVL 4

Accepted Solution

by:
orbitus earned 0 total points
Comment Utility
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
    DeleteAllTables
    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
    DeleteAllTables
    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
HitEmAgain:
    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
    Else
       'varTest = rstRecords.GetRows()


        Set db2 = CurrentDb
        'Set rst = db2.OpenRecordset("SourceTable")
        DeleteTableAndRelation strTableName
        Set tdfNew = db2.CreateTableDef(strTableName)
        'rstRecords.MoveFirst
           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
               tdfNew.Fields.Refresh
               Set fldNew = Nothing
               'rstRecords.MoveNext
           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, _
                 LockType:=adLockOptimistic
   
        'now loop through the recordset you passed in and add
        'each record to the temp table
        rstRecords.MoveFirst
        'On Error Resume Next
        Do While Not rstRecords.EOF
            rst.AddNew
                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
                    Else
                        rst.Fields(fld.Name).Value = fld.Value
                    End If
                Next
            rst.Update
            rstRecords.MoveNext
        Loop
   
        'cleanup
        rst.Close
        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
   
    rstRecords.Close
    Set rstRecords = Nothing
    cnn1.Close
    Set cnn1 = Nothing
    Set cmdExeproc = Nothing

DeleteExit:
    Exit Sub

DeleteErr:
    If Err = 3265 Then
        SysCmd acSysCmdSetStatus, "Working on " & strFullTableName
    ElseIf Err = -2147467259 Then
        sSleep (2000)
        SysCmd acSysCmdSetStatus, "Got held up at " & strFolder
        Resume HitEmAgain
    Else
        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.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

When you are entering numbers in a speadsheet, and don't remember what 6×7 is, you just type “=6*7" instead. It works in every cell! This is not so in Access. To enter the elusive 42 in a text box, you have to find a calculator, and then copy the re…
Today's users almost expect this to happen in all search boxes. After all, if their favourite search engine juggles with tens of thousand keywords while they type, and suggests matching phrases on the fly, why shouldn't they expect the same from you…
Familiarize people with the process of retrieving data from SQL Server using an Access pass-thru query. Microsoft Access is a very powerful client/server development tool. One of the ways that you can retrieve data from a SQL Server is by using a pa…
With Microsoft Access, learn how to start a database in different ways and produce different start-up actions allowing you to use a single database to perform multiple tasks. Specify a start-up form through options: Specify an Autoexec macro: Us…

744 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

18 Experts available now in Live!

Get 1:1 Help Now