Solved

VBA to open folder in Outlook from Access 2003

Posted on 2009-06-29
2
547 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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

Enroll in July's Course of the Month

July's Course of the Month is now available! Enroll to learn HTML5 and prepare for certification. It's free for Premium Members, Team Accounts, and Qualified Experts.

Question has a verified solution.

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

As tax season makes its return, so does the increase in cyber crime and tax refund phishing that comes with it
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

624 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