I'm working on a macro for Microsoft Outlook that's supposed to export emails from a user-picked folder to an Access database, in a slightly more specific way than the standard wizard way to do it. I do this by having one main subroutine, called by the user, which opens and prepares all database connections and other necessary public variables, and calls a second sub with a folder object containing the selected outlook folder as a call argument.
The second sub loops through the folder object for subfolders and emails. When finding an email, it extracts the info i want to save and puts it into the Access database. This is working correctly. However, when finding a subfolder, the sub is supposed to call itself, to start the same procedure for the subfolder. But when the first subfolder has been looped through (i.e. where the nested call is finished) the sub somehow interrupts itself, instead of continuing the loop.
Below I have provided the code for the two subroutines. FileExists and IssueNumberInString are two functions that work correctly, so i haven't provided the code for them.
Please help me with how to solve this...!
Expand|Select|Wrap|Line Numbers
- Option Explicit
- ' Declare public variables
- Dim strDbFilePath As String
- Dim appAccess As Access.Application
- Dim adoConn As ADODB.Connection
- Dim strISS As String
- Dim nsOlMapi As Outlook.NameSpace
- Sub ArchiveEmail()
- ' Prepare Access Application
- Set appAccess = New Access.Application
- ' Test if database exists, otherwise give error message
- strDbFilePath = "H:\mail archive test\mailarchive.mdb"
- If Not FileExists(strDbFilePath) Then
- MsgBox "Could not find database! Please contact your system administrator.", vbCritical, "Archive Email"
- Exit Sub
- End If
- ' Let user pick folder to export
- Set nsOlMapi = GetNamespace("MAPI")
- Dim objFolder As Outlook.MAPIFolder
- Set objFolder = nsOlMapi.PickFolder
- ' Open database connection
- Set adoConn = CreateObject("ADODB.Connection")
- adoConn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source = " & strDbFilePath & ";User ID=Admin;Password=;"
- adoConn.Open
- ' Loop through folder and export all emails (EXTERNAL SUB)
- Call ExtractEmailsToDatabase(objFolder)
- MsgBox "Emails archived successfully!", vbInformation, "Archive Email"
- ' Close database connection
- adoConn.Close
- ' Dispose all objects to free memory
- Set appAccess = Nothing
- Set adoConn = Nothing
- Set nsOlMapi = Nothing
- Set objFolder = Nothing
- End Sub
- Sub ExtractEmailsToDatabase(ByVal objFolder As Outlook.MAPIFolder)
- ' Extracts all emails from a folder and subfolders into the Access database
- ' Loop through folder
- Dim intCtr
- ' Look for subfolders. Call this sub for any found folders
- If objFolder.Folders.Count > 0 Then
- For intCtr = 1 To objFolder.Folders.Count Step 1
- MsgBox "entering subfolder " & intCtr & " of " & objFolder.Folders.Count & "..."
- Call ExtractEmailsToDatabase(objFolder.Folders(intCtr))
- MsgBox "exiting subfolder..." ' This message is never shown...
- Next
- End If
- Dim MailItem As Object
- ' Look for emails. Export any found emails
- If objFolder.Items.Count > 0 Then
- For Each MailItem In objFolder.Items
- With MailItem
- If .Class = olMail Then
- MsgBox "email found!"
- If Len(IssueNumberInString(.Subject)) > 0 Then
- strISS = IssueNumberInString(.Subject)
- ElseIf Len(IssueNumberInString(objFolder.Name)) > 0 Then
- strISS = IssueNumberInString(objFolder.Name)
- Else
- strISS = InputBox("Could not decipher ISS number from folder name or subject!" & vbCrLf & _
- "Please enter the issue number for emails in folder " & objFolder.Name, "Archive Emails")
- End If
- ' Email object
- ' Export email by calling connection object
- ' Currently omitted variables:
- ' FromAdress,ToAdress,CCAdress,BCCAdress,Attachements
- adoConn.Execute ("INSERT INTO tblEMAIL (" & _
- "ISS,Subject,Body,FromName,ToName," & _
- "CCName,BCCName,Importance,Sensitivity" & _
- ") VALUES ('" & _
- strISS & "','" & .Subject & "','" & _
- .Body & "','" & .SenderName & "','" & _
- .To & "','" & .CC & "','" & _
- .BCC & "','" & .Importance & "','" & .Sensitivity & "')")
- End If
- End With
- Next MailItem
- End If
- End Sub
Thank you for any help!