Map Contact Addresses or Meeting Locations

Last reviewed on August 1, 2014   —  4 comments

map directions for multiple contacts

While Outlook's MapIt button can be reprogrammed to use another map service, you'll need to use VBA if you want to use a second map service or map multiple addresses or locations at once.

Jerry wanted to use Zillow but he uses Outlook 2003 and Outlook 2003's map service can't be reprogrammed, so in the first example, I'm using Zillow. Although Zillow seems to accept anything Outlook throws at them (%20 for spaces, + as word separators, no separators), their default spacer is a dash, so I'm using a function to replace spaces in the address with a dash. It makes a prettier URL too. :)

I'm constructing the address from the individual address fields but you could simply use strAddress = oContact.BusinessAddress or strAddress = oContact.HomeAddress.

This macro may work in Outlook 2002 and Outlook 2000; however I did not test it in those versions. It was tested in Outlook 2003 and up.

Map an Address Macro

Press Alt+F11 to open the VBA editor and paste the code into ThisOutlookSession. Customize the toolbar, ribbon, or QAT, by adding the macro to a button in the main Outlook window. Select the Contact and run the macro.


 
Sub MapAddress()
  
  Dim strURL As String
  Dim oApp As Object
  Dim strAddress As String

  Set oApp = CreateObject("InternetExplorer.Application")

If TypeName(ActiveExplorer.Selection.Item(1)) = "ContactItem" Then
 Set oContact = ActiveExplorer.Selection.Item(1)


strAddress = oContact.BusinessAddressStreet & "-" & oContact.BusinessAddressCity & "-" & oContact.BusinessAddressState

ReplaceSpaces strAddress
strURL = "http://www.zillow.com/homes/" & strAddress


oApp.navigate (strURL)
oApp.Visible = True

'wait for page to load before passing the web URL
Do While oApp.Busy
  DoEvents
Loop
 End If


Set oApp = Nothing
End Sub



Private Sub ReplaceSpaces(strAddress As String)
  strAddress = Replace(strAddress, " ", "-")
End Sub

For google maps, use this url:

strURL = "https://maps.google.com/maps?f=q&source=s_q&hl=en&geocode=&q=" & strAddress

Map a Meeting Location

Use this macro to map an address in a meeting or appointment's Location field.

This macro will work with either selected or opened appointments. You'll need the GetCurrentItem function to use it.

If you need to use a location in the appointment body, use regex to capture the address.

Sub MapLocation()
   
  Dim strURL As String
  Dim oApp As Object
  Dim strAddress As String

  Set oApp = CreateObject("InternetExplorer.Application")
 
 Set oAppt = GetCurrentItem()
 
strAddress = oAppt.Location
 
ReplaceSpaces strAddress
strURL = "https://maps.google.com/maps?f=q&source=s_q&hl=en&geocode=&q=" & strAddress
 
 
oApp.navigate (strURL)
oApp.Visible = True
 
'wait for page to load before passing the web URL
Do While oApp.Busy
  DoEvents
Loop


Set oApp = Nothing
End Sub
 

Private Sub ReplaceSpaces(strAddress As String)
  strAddress = Replace(strAddress, " ", "-")
End Sub

 

Map Multiple Addresses or Locations

You can get directions to multiple addresses using Google Maps with a URL formatted like this: https://www.google.com/maps/dir/street+city+state+zip/street+city+state+zip.

Use Current+Location to begin at your location or add your address as the first string. https://www.google.com/maps/dir/Current+Location/street+city+state+zip/street+city+state+zip.

I'm using a select case statement so we can use one macro for both appointments/meetings and contacts. I'm also using an If Statement to get a home address if the business address doesn't exist.

To use, select the contacts in first stop to last order and run the macro. Appointment locations are mapped first appointment to last. It works with any calendar or contacts folder in your profile.


Public Sub MapMultipleAddresses()
 
Dim Session As Outlook.NameSpace
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim oItem As Object
Dim strURL As String
Dim oApp As Object
Dim strAddress As String

Set oApp = CreateObject("InternetExplorer.Application")
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection

On Error Resume Next

For Each oItem In Selection

 
Select Case oItem.Class
 Case olContact
 If oItem.BusinessAddressCity = "" Then
 
 strAddress = strAddress & "/" & oItem.HomeAddressStreet & "+" & _
    oItem.HomeAddressCity & "+" & oItem.HomeAddressState
    
 Else
  strAddress = strAddress & "/" & oItem.BusinessAddressStreet & "+" & _
    oItem.BusinessAddressCity & "+" & oItem.BusinessAddressState

 End If

Case olAppointment, olMeeting
 strAddress = strAddress & "/" & oItem.Location
End Select

Err.Clear
Next

' replace spaces with +
strAddress = Replace(strAddress, " ", "+")

' use dir/Current+Location to start at your location
' or add your address to the url
strURL = "https://www.google.com/maps/dir" & strAddress

oApp.navigate (strURL)
oApp.Visible = True
 
'wait for page to load before passing the web URL
Do While oApp.Busy
    DoEvents
Loop

Set oApp = Nothing
Set Session = Nothing
Set currentExplorer = Nothing
Set oItem = Nothing
Set Selection = Nothing
End Sub


Using Firefox or Chrome Browser

If you want to use a different browser, you need to use the shell command to load the browser then pass the url to it. The shell command will look like this, with the full path to the browser. You need a space between the path to the browser and the url.

Shell ("C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " " & strURL), vbNormalFocus

The path in my examples is for 64-bit Windows. If you use 32-bit Windows, the path will be C:\Program Files\Google\Chrome\Application\chrome.exe


Sub MapAddress()
  
  Dim strURL As String
  Dim strAddress As String

If TypeName(ActiveExplorer.Selection.Item(1)) = "ContactItem" Then
 Set oContact = ActiveExplorer.Selection.Item(1)


strAddress = oContact.BusinessAddressStreet & "-" & oContact.BusinessAddressCity & "-" & oContact.BusinessAddressState

ReplaceSpaces strAddress
strURL = "http://www.zillow.com/homes/" & strAddress

'Shell ("C:\Program Files (x86)\Mozilla Firefox\firefox.exe" & " " & strURL), vbNormalFocus
Shell ("C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " " & strURL), vbNormalFocus

End If

End Sub


Private Sub ReplaceSpaces(strAddress As String)
  strAddress = Replace(strAddress, " ", "-")
End Sub

Create your own MapIt button in a custom form

To create your own MapIt button in a custom form, you need to remove a few lines of the code. This goes in the View Code window. Add a command button called cmdMap to call the script.

Sub cmdMap_click()
Set oApp = CreateObject("InternetExplorer.Application")
strAddress = item.BusinessAddressStreet & "+" & item.BusinessAddressCity & "+" & item.BusinessAddressState
strAddress = Replace(strAddress, " ", "+")
strURL = "https://maps.google.com/maps?f=q&source=s_q&hl=en&geocode=&q=" & strAddress
oApp.navigate (strURL)
oApp.Visible = True
End Sub
   

Written by

Diane Poremsky
A Microsoft Outlook Most Valuable Professional (MVP) since 1999, Diane is the author of several books, including Outlook 2013 Absolute Beginners Book. She also created video training CDs and online training classes for Microsoft Outlook. You can find her helping people online in Outlook Forums as well as in the Microsoft Answers and TechNet forums.

Please post long or more complicated questions at Outlookforums.

4 responses to “Map Contact Addresses or Meeting Locations”

  1. Kiran

    Thanks, Really this code is very useful for me.

    I need to put all my contact on one google map.

    What can I do??

  2. Haik

    Hello Diane, I would like to have a macro in Outlook (when I make an appointment) which extracts the traveldistance (and driving time) from google maps.
    How do I do that?

Leave a Reply

If the Post Coment button disappears, press your Tab key.