Solved

VBA to open folder in Outlook from Access 2003

Posted on 2009-06-29
2
538 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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

I originally created this report in Crystal Reports 2008 where there is an option to underlay sections. I initially came across the problem in Access Reports where I was unable to run my border lines down through the entire page as I was using the P…
I see at least one EE question a week that pertains to using temporary tables in MS Access.  But surprisingly, I was unable to find a single article devoted solely to this topic. I don’t intend to describe all of the uses of temporary tables in t…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
What’s inside an Access Desktop Database. Will look at the basic interface, Navigation Pane (Database Container), Tables, Queries, Forms, Report, Macro’s, and VBA code.

863 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

24 Experts available now in Live!

Get 1:1 Help Now