Solved

VBA to open folder in Outlook from Access 2003

Posted on 2009-06-29
2
537 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
Comment Utility
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
Comment Utility
Thanks
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Suggested Solutions

In Debugging – Part 1, you learned the basics of the debugging process. You learned how to avoid bugs, as well as how to utilize the Immediate window in the debugging process. This article takes things to the next level by showing you how you can us…
Introduction The Visual Basic for Applications (VBA) language is at the heart of every application that you write. It is your key to taking Access beyond the world of wizards into a world where anything is possible. This article introduces you to…
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…
In Microsoft Access, when working with VBA, learn some techniques for writing readable and easily maintained code.

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

13 Experts available now in Live!

Get 1:1 Help Now