Solved

Create a query dynamically for every subfolder in an exchange mailbox

Posted on 2006-11-27
2
410 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
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
    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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

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

Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
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…
Familiarize people with the process of utilizing SQL Server views from within Microsoft Access. Microsoft Access is a very powerful client/server development tool. One of the SQL Server objects that you can interact with from within Microsoft Access…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

685 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