Solved

VBA to open folder in Outlook from Access 2003

Posted on 2009-06-29
2
541 Views
Last Modified: 2013-11-27
I need some vba in Access that can open a folder of a currently running process of outlook.  For example I want to be able to press a button in an Access form and have a folder called:

outlook:\\KitBackupInboxDumpster8-29-2007\|______| Tasks |______| \Big Tasks

be opened.

"KitBackupInboxDumpster8-29-2007" is the name of the PST that is mounted and "\|______| Tasks |______| \Big Tasks" is the sub-folder structure.

My goal is to not have a new instance of outlook created but to use the existing one.
0
Comment
Question by:kh0rn3
2 Comments
 
LVL 31

Accepted Solution

by:
Helen_Feddema earned 500 total points
ID: 24744247
Here is some code that runs from a command button (with an associated textbox control) that lets you select an Outlook folder from the FolderPicker dialog.  After running this code, which saves the folder path to a custom database property, you can retrieve it and use it elsewhere with a line of code.  My code uses GetFolder, SetPropety and GetProperty procedures; the database that includes all of these procedures is attached.

I prefer this method to hard-coding the path, since it assures that you have the correct syntax, and you can see the path right on the main menu when you open the database.  My code filters for a Contacts-type folder, but you can change it to the type of folder you are opening.



[in a form module]
 
Private Sub cmdOutlookFolder_Click()
'Created by Helen Feddema 9-Aug-2008
'Last modified 9-Aug-2008
 
On Error GoTo ErrorHandler
   
   Dim nms As Outlook.NameSpace
   Dim fld As Outlook.MAPIFolder
   
   Set appOutlook = New Outlook.Application
   Set nms = appOutlook.GetNamespace("MAPI")
   Set txt = Me![txtOutlookFolder]
   
SelectContactFolder:
   Set fld = nms.PickFolder
   If fld Is Nothing Then
      MsgBox "Please select a Contacts folder"
      GoTo SelectContactFolder
   End If
 
   'Check that the selected folder is a Contacts folder,
   'and put up PickFolder dialog again if not
   Debug.Print "Default item type: " & fld.DefaultItemType
   If fld.DefaultItemType <> olContactItem Then
      MsgBox "Please select a Contacts folder"
      GoTo SelectContactFolder
   End If
 
   'Save folder path to a custom database property
   strFolderPath = fld.FolderPath
   strPropertyName = "FolderPath"
   lngDataType = dbText
   Call SetProperty(strPropertyName, lngDataType, _
      strFolderPath)
   txt.Value = strFolderPath
   
ErrorHandlerExit:
   Exit Sub
 
ErrorHandler:
   'Outlook is not running; open Outlook with CreateObject
   If Err.Number = 429 Then
      Set appOutlook = CreateObject("Outlook.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
 
End Sub
 
Private Sub cmdImportContacts_Click()
'Created by Helen Feddema 9-Aug-2008
'Last modified 9-Aug-2008
 
On Error GoTo ErrorHandler
   
   Dim con As Outlook.ContactItem
   Dim dbs As DAO.Database
   Dim fld As Outlook.MAPIFolder
   Dim i As Integer
   Dim intReturn As Integer
   Dim itm As Object
   Dim lngCount As Long
   Dim rst As DAO.Recordset
   Dim strSalutation As String
   
   'Attempt to get folder path from custom database property,
   'and reopen main menu if not found
   strFolderPath = GetProperty("FolderPath", "")
   If strFolderPath = "" Then
      strTitle = "Path not selected"
      strPrompt = "Please select the Outlook folder on the main menu"
      MsgBox prompt:=strPrompt, _
         buttons:=vbExclamation + vbOKOnly, _
         Title:=strTitle
      If prj.AllForms("fmnuMain").IsLoaded Then
         Forms![fmnuMain].Visible = True
      Else
         DoCmd.OpenForm "fmnuMain"
      End If
      DoCmd.Close acForm, Me.Name
      GoTo ErrorHandlerExit
   Else
      Debug.Print "Outlook folder path: " & strFolderPath
      Set fld = GetFolder(strFolderPath)
   End If
   
   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset("tblContacts")
   
   'Check whether there are any items in the selected folder
   lngCount = fld.Items.Count
   
   If lngCount = 0 Then
      strTitle = "Folder empty"
      strPrompt = "The selected folder is empty; canceling"
      MsgBox prompt:=strPrompt, _
         buttons:=vbExclamation + vbOKOnly, _
         Title:=strTitle
      GoTo ErrorHandlerExit
   End If
   
   'Process all contacts in selected folder
   i = 0
   
   For Each itm In fld.Items
      If itm.Class = olContact Then
         Set con = itm
         
         'Put up confirmation dialog for each contact to import;
         'comment out the message box lines if you want to import
         'all contacts from the folder automatically
         strTitle = "Question"
         strPrompt = "Import " & con.FullName _
            & "'s contact data into Access table?"
         intReturn = MsgBox(prompt:=strPrompt, _
            buttons:=vbQuestion + vbYesNo, _
            Title:=strTitle)
         If intReturn = vbNo Then
            GoTo NextContact
         ElseIf intReturn = vbYes Then
            rst.AddNew
            rst![FirstName] = Nz(con.FirstName)
            rst![LastName] = Nz(con.LastName)
            If Nz(con.Nickname) <> "" Then
               strSalutation = con.Nickname
            Else
               strSalutation = con.FirstName
            End If
            rst![Salutation] = strSalutation
            rst![StreetAddress] = Nz(con.BusinessAddress)
            rst![City] = Nz(con.BusinessAddressCity)
            rst![StateOrProvince] = Nz(con.BusinessAddressState)
            rst![PostalCode] = Nz(con.BusinessAddressPostalCode)
            rst![Country] = Nz(con.BusinessAddressCountry)
            rst![CompanyName] = Nz(con.CompanyName)
            rst![JobTitle] = Nz(con.JobTitle)
            rst![WorkPhone] = Nz(con.BusinessTelephoneNumber)
            rst![MobilePhone] = Nz(con.MobileTelephoneNumber)
            rst![FaxNumber] = Nz(con.BusinessFaxNumber)
            rst![EmailName] = Nz(con.Email1Address)
            rst.Update
            i = i + 1
         End If
      End If
      
NextContact:
   Next itm
   
   strTitle = "Import done"
   strPrompt = i & " contacts imported into tblContacts"
   MsgBox prompt:=strPrompt, _
      buttons:=vbInformation + vbOKOnly, _
      Title:=strTitle
   
ErrorHandlerExit:
   Exit Sub
 
ErrorHandler:
   'Outlook is not running; open Outlook with CreateObject
   If Err.Number = 429 Then
      Set appOutlook = CreateObject("Outlook.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
 
End Sub
 
[in a standard module]
Public Sub SetProperty(strName As String, lngType As Long, _
   varValue As Variant)
'Created by Helen Feddema 2-Oct-2006
'Modified by Helen Feddema 2-Oct-2006
'Called from various procedures
 
On Error GoTo ErrorHandler
 
   'Attempt to set the specified property
   Set dbs = CurrentDb
   Set prps = dbs.Properties
   prps(strName) = varValue
 
ErrorHandlerExit:
   Exit Sub
 
ErrorHandler:
    If Err.Number = 3270 Then
      'The property was not found; create it
      Set prp = dbs.CreateProperty(Name:=strName, _
         Type:=lngType, Value:=varValue)
      dbs.Properties.Append prp
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
 
End Sub
 
Public Function GetProperty(strName As String, strDefault As String) _
   As Variant
'Created by Helen Feddema 2-Oct-2006
'Modified by Helen Feddema 2-Oct-2006
'Called from various procedures
 
On Error GoTo ErrorHandler
   
   'Attempt to get the value of the specified property
   Set dbs = CurrentDb
   GetProperty = dbs.Properties(strName).Value
 
ErrorHandlerExit:
   Exit Function
 
ErrorHandler:
   If Err.Number = 3270 Then
      'The property was not found; use default value
      GetProperty = strDefault
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
 
End Function
 
Public Function ListCustomProps()
'Created by Helen Feddema 3-Oct-2006
'Modified by Helen Feddema 3-Oct-2006
'Lists DB properties created in code (as well as built-in properties)
 
On Error Resume Next
   
   Set dbs = CurrentDb
   Debug.Print "Database properties:"
   
   For Each prp In dbs.Properties
      Debug.Print vbTab & prp.Name & ": " & prp.Value
   Next prp
 
End Function
 
Function GetFolder(ByVal strFolderPath As String) As Outlook.MAPIFolder
'Created by Helen Feddema 5-Aug-2008
'Last modified 9-Aug-2008
 
On Error GoTo ErrorHandler
 
   Dim flds As Outlook.Folders
   Dim fldTest As Outlook.MAPIFolder
   Dim varFolders As Variant
   Dim i As Integer
   Dim appOutlook As Outlook.Application
   Dim nms As Outlook.NameSpace
   
   If Left(strFolderPath, 2) = "\\" Then
      strFolderPath = Right(strFolderPath, Len(strFolderPath) - 2)
   End If
    
   'Convert strFolderPath to array
   Set appOutlook = GetObject(, "Outlook.Application")
   Set nms = appOutlook.GetNamespace("MAPI")
   varFolders = Split(strFolderPath, "\")
   Set fldTest = nms.Folders.Item(varFolders(0))
   If Not fldTest Is Nothing Then
      For i = 1 To UBound(varFolders, 1)
         Set flds = fldTest.Folders
         Set fldTest = flds.Item(varFolders(i))
         If fldTest Is Nothing Then
            Set GetFolder = Nothing
         End If
      Next
   End If
   
   'Return the selected folder
   Set GetFolder = fldTest
   GoTo ErrorHandlerExit
       
ErrorHandlerExit:
   'Set GetFolder = Nothing
   Exit Function
 
ErrorHandler:
   'Outlook is not running; open Outlook with CreateObject
   If Err.Number = 429 Then
      Set appOutlook = CreateObject("Outlook.Application")
      Resume Next
   Else
      MsgBox "Error No: " & Err.Number _
         & "; Description: " & Err.Description
      Resume ErrorHandlerExit
   End If
 
End Function

Open in new window

Folder-Path-Selectors--AA-185-.mdb
0
 

Author Closing Comment

by:kh0rn3
ID: 31598070
Thanks
0

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

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…
Phishing attempts can come in all forms, shapes and sizes. No matter how familiar you think you are with them, always remember to take extra precaution when opening an email with attachments or links.
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…
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…

772 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