How to control Outlook from Word

Article contributed by Jeff Vandervoort and Dave Rado

There are basically three ways reading and writing from Outlook, using Word VBA. You can use GetAddress, which is fast but very clunky and very limiting.You can use OLE automation to acess the Outlook object model (which is slow) or you can use CDO (which is very fast).

“Progranmming with MS Outlook and MS Exchange” by Thomas Rizzo, MS Press, ISBN 0-7356-0509-2, has been recommended tov me as a book which covers CDO very well.

If you're using Outlook 98, you'll already have the CDO type library and can just set a reference to it. If you have Outlook 97, you'll need to download the CDO type library from the Microsoft site.

If you limit the number of fields you extract from each contact, CDO can rival the speed with which the built-in GetAddress dialog is populated. I found it to be approximately 6 times faster than using the Outlook object on my machine.

Once you set a reference to it (Tools/References) it's available to your VBA project. It uses MAPI to give you programatic access to folders and messages in .PSTs and on Exchange Servers. The followng code example is rough...but it works & will get you started. The current version of this in my project has evolved quite a bit and would not be useful to post.

Disclaimer: This code is a cassarole of various KB articles, Help files, FAQ sites, my own previous unsatisfactory attempts, and other sources. It is a work-in-progress, lacks elegance, coding style consistency and has almost no error handling, and probably even a few bugs...but it works and it's fast. It is not “generic”, either, so you'll have to adapt it to your situation. But if that bothers you, consider what you paid for it <g>.

This first procedure is run by the DropButtonClick event of a combobox. It fills the list if it's empty, and if the list is closing after a selection is made, it looks up additional information about the contact (currently, only the fax number). Ctl is the combobox object passed as an argument from the document's class module (it could easily be rewritten as the event procedure itself...it was just better in my app to do it this way). The strategy that works best to build the list is to use CDO. It's very quick where the Outlook object is slow. But after the user makes their selection, I prefer to get the contact properties from Outlook because MS has provided lots of pre-concatenated and pre-parsed combinations of name/address info that are useful to my app and will save me some code. You could also get them from CDO, but you're on your own for that! The Entry ID is the same for .PST objects, whether accessed through CDO or Outlook, and both can use the same MAPI session (though my code doesn't do that, unfortunately.)

Speaking of CDO, I've found that you cannot get the company name from the AddressEntries collection. There's a property for it, .Fields(CdoPR_COMPANY_NAME), but it doesn't work. That's OK because I'm not using the AddressEntries collection, I'm using the Messages collection (which is also the solution to my previous problems about getting an incomplete list from CDO). Just another FYI I learned the hard way!

Public Sub cboTo_DropButtonClick(Ctl As Object)

'general

Static listOpen As Boolean
Dim lstIndx As Long
Dim galError As Boolean
Dim contactList() As Variant
Dim counter As Long
Dim coName As String

'CDO & Outlook
Dim objSession As MAPI.Session
Const contactFolder As String = "Contacts"

'Outlook
Dim olContact As ContactItem
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace

listOpen = Not listOpen
If Ctl.ListCount = 0 Then
    'contact list not yet imported this session
    ' create a session and log on
    Set objSession = StartQuietSession(NoMailServices:=True)
    System.Cursor = wdCursorWait
    galError = GetAddressList(Session:=objSession, _
    FolderName:=contactFolder, ReturnArray:=contactList())
    SortArray ArrayName:=contactList
    'sort by name

    'find out how many records have company names w/o display names
    For counter = 0 To UBound(contactList)
        If contactList(counter, 0) <> "" Then Exit For
    Next

    'sort by co. name for records w/o names
    'Blake: SortArray is a VBA procedure I wrote to replace
    'WordBasic.SortArray
    'you can do this with WordBasic.SortArray, too
    If counter > 1 Then _
        SortArray ArrayName:=contactList, SortFrom:=0, SortTo:=counter - 1, SortKey:=1
        Ctl.List = contactList
        'close session and logoff
        objSession.Logoff
        StatusBar = ""
        System.Cursor = wdCursorNormal
    End If

If Not listOpen Then
    'enter info in other controls found in doc
    Set objSession = StartQuietSession(NoMailServices:=True)
    lstIndx = Ctl.ListIndex

    If lstIndx > -1 Then
        coName = Ctl.List(lstIndx, 1)

        With ActiveDocument
            'Blake: ControlExists is a procedure that loops thru all controls in a doc to see if
            'the specified control exists; it will not be applicable outside of my app, but illustrates
            'how you can get the info out of the list
            If ControlExists(ControlName:="txtCompany") Then .txtcompany = coName
            If ControlExists(ControlName:="cboCompany") Then .cboCompany = coName
            .CustomDocumentProperties("DocTo").Value = Ctl
            .CustomDocumentProperties("DocCompany").Value = coName

            'from here on, get info from Outlook object to benefit from Outlook's
            'parsing and concatenating contact properties
            '(remember: listbox entries came from CDO for speed of building list)
            'GetObject doesn't seem any faster, here, contrary to docs
            Set olApp = New Outlook.Application
            Set olNS = olApp.GetNamespace("MAPI")
            Set olContact = olNS.GetItemFromID(Ctl.List(lstIndx, 2))
            If ControlExists(ControlName:="txtFaxNumber") Then _
                .txtfaxnumber = olContact.BusinessFaxNumber
            End If
        End With

    End If

    'close session and logoff
objSession.Logoff
    Set olApp = Nothing
    Set olNS = Nothing
    Set olContact = Nothing

End If

End Sub

Public Function StartQuietSession(NoMailServices As Boolean) As MAPI.Session

'attempts to log on to MAPI with using existing session
'if no session exists, logs on with default profile
'returns session object if successful (through either means), Nothing if
' unsuccessful derived from MSKB article Q171422 "Logging onto Active
'Messaging session with default profile" rewrote as a function,
'modified for compat. with JRVsystems modRegistry module

Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserProfile As String
Dim retvalue As Long
Dim objSession As MAPI.Session

StatusBar = "Please wait: Communicating with Outlook..."
System.Cursor = wdCursorWait
On Error GoTo ErrorHandler
Set objSession = CreateObject("MAPI.Session")

'Try to logon. If this fails, the most likely reason is
'that you do not have an open session. The error
'-2147221231 MAPI_E_LOGON_FAILED will return. Trap
'the error in the ErrorHandler

objSession.Logon ShowDialog:=False, NewSession:=False
Set StartQuietSession = objSession
StatusBar = ""
System.Cursor = wdCursorNormal
Exit Function

ErrorHandler:
    Select Case Err.Number
        Case -2147221231 'MAPI_E_LOGON_FAILED
            'Need to find out what OS is in use, the keys are different
            'for WinNT and Win9x.
            Select Case System.OperatingSystem
                Case "Windows" '= Win 9x
                    sKeyName = "Software\Microsoft\Windows Messaging " & _
                            "Subsystem\Profiles"
                Case "Windows NT"
                    sKeyName = "Software\Microsoft\Windows NT\CurrentVersion\" & _
                            "Windows Messaging Subsystem\Profiles"
            End Select

            sValueName = "DefaultProfile"
            'Blake: QueryValue is in another of my library modules.
            'You can use System.PrivateProfileString to
            'do the same thing (I just use this because it can be used in
            'any VBA or VB app, which don't have an
            'equivalent for System.PrivateProfileString
            sDefaultUserProfile = QueryValue(sKeyName, sValueName, _
                    HKEY_CURRENT_USER)

            'NoMail argument not documented in Help file,
            'but appears to load (and later unload) only the .PST
            'which greatly speeds up operation since we don't need the other services
            'esp. fax which is glacial

            objSession.Logon ProfileName:=sDefaultUserProfile, _
            ShowDialog:=False, NoMail:=NoMailServices
            Set StartQuietSession = objSession
            StatusBar = ""
            System.Cursor = wdCursorNormal
            Exit Function

        Case Else
            StatusBar = ""
            System.Cursor = wdCursorNormal
            MsgBox "An error has occured while attempting" & Chr(10) & _
                    "To create and logon to a new ActiveMessage session." & _
                    Chr(10) & "Please report the following error to your " & _
                    "System Administrator." & Chr(10) & Chr(10) & _
                    "Error Location: frmMain.StartMessagingAndLogon" & _
                    Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
                    "Description: " & Err.Description
    End Select

End Function

Function GetAddressList(Session As MAPI.Session, FolderName As String, _
ReturnArray() As Variant) As Boolean

'Returns true if successful, false if not
'FolderName = name of Outlook (or other MAPI) folder to look in
'ReturnArray = 3-column array to be populated by GetAddressList for use in
'listbox/combobox
' col0 = Name
' col1 = Company
' col2 = unique ID
'if Name and Company are both "", skips the oneMessage record
'because there's nothing to display
'adapted from MSKB article Q172093 -
'HOWTO Access MAPI Address Books with Active Messaging 1.1

Dim collInfoStores As InfoStores
Dim objFolder As Folder
Dim collMessages As Messages
Dim oneMessage As Message
Dim counter As Long
Dim numContacts As Long
Dim nm As String
Dim co As String

'empirically, "Top of Personal Folders" is top folder name with Outlook 98
'regardless of friendly name of PST (which, by default, is "Personal Folders")
'IOW, if PST friendly name is "My Message Store", top folder is still called
'"Top of Personal Folders", not "Top of My Message Store"

Set objFolder = FindTargetFolder(objSession:=Session, _
        strTargetTopFolder:="Top of Personal Folders", _
        strSearchName:=FolderName)

Set collMessages = objFolder.Messages

'per KB, Messages is a "large collection", so .Count property may be incorrect
'so we'll count them ourselves (essentially instantaneous...why can't CDO do this??)

For Each oneMessage In collMessages
    numContacts = numContacts + 1
Next

ReDim ReturnArray(numContacts - 1, 2)

For Each oneMessage In collMessages
    StatusBar = "Please wait. Getting contacts from Outlook " & _
    Format(counter / numContacts, "(0%)")
    'have to initialize at each pass, because empty fields raise an error,
    'so variable retains previous (now incorrect) value
    nm = ""
    co = ""
    With oneMessage
        On Error Resume Next
        nm = .Fields(CdoPR_DISPLAY_NAME)
        co = .Fields(CdoPR_COMPANY_NAME)
        On Error GoTo 0
        If nm <> "" Or co <> "" Then
            'unlikely, but both could be "" in which case we won't have much to show...
            ReturnArray(counter, 0) = nm
            ReturnArray(counter, 1) = co
            ReturnArray(counter, 2) = .id
            counter = counter + 1
        End If
    End With
Next oneMessage

Set collInfoStores = Nothing
Set objFolder = Nothing
Set collMessages = Nothing
GetAddressList = True

End Function

Private Function FindTargetFolder(objSession As MAPI.Session, _
strTargetTopFolder As String, _
strSearchName As String) As Folder

'adapted from MSKB article Q171638
Dim objInfoStores As InfoStores
Dim objInfoStore As InfoStore
Dim objTopFolder As Folder
Dim objPSTFolders As Folders
Dim i As Long
Dim er As Long

Set objInfoStores = objSession.InfoStores

'This loop finds the TopFolder you specified.
For i = 1 To objInfoStores.Count
    Set objInfoStore = objInfoStores(i)
    Set objTopFolder = Nothing
    On Error Resume Next
    Set objTopFolder = objInfoStore.RootFolder
    er = Err.Number
    On Error GoTo 0
    If Not er = -2147221227 Then
        'MAPI_E_NETWORK_ERROR
        If objTopFolder.Name = strTargetTopFolder Then
            'Found PST
            'Because you can have more than one PST in a profile,
            'you may want to put another check here to make sure you have
            'the correct PST. This check would need to specify a string
            'that is the name of the PST you are looking for.
            'It would look something like this:
            'If objInfoStore.Name = "MyPST" Then 'Found own PST
                ' Exit For
            'End If
        End If
    End If
Next i

Set objPSTFolders = objTopFolder.Folders

For i = 1 To objPSTFolders.Count
    'MsgBox objPSTFolders.Item(i).Name
    If objPSTFolders.Item(i).Name = strSearchName Then
        Exit For
    End If
Next i

Set FindTargetFolder = objPSTFolders.Item(i)
Set objTopFolder = Nothing
Set objPSTFolders = Nothing
Set objInfoStores = Nothing
Set objInfoStore = Nothing

End Function