Mapping Annoyance

[Matt Williamson]

Since MS decided to hard code (or put somewhere other than the registry)
http://r.office.microsoft.com/r as the default location for the map button
in Outlook 2003 and it can no longer be changed in the registry using the
MapScriptURL registry value, I decided to write some code to give better
options. I wrote this as a replacement to the map button on the contact form
so it only works when a contact is open and has an address set as the
mailing address.

'Code Start

Option Explicit

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA"
_
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String,
ByVal _
lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long)
_
As Long

Public Declare Function GetDesktopWindow Lib "user32" () As Long

Public Enum MappingService
Google = 1
Expedia = 2
Mappoint = 3
MapQuest = 4
YahooMaps = 5
End Enum


Sub openmap()
OpenMapFromContact Google
End Sub


Sub OpenMapFromContact(Map As MappingService)

Dim itm As Outlook.ContactItem, s As String
Dim sStreet As String, sCity As String, sZip As String
Dim sState As String, sURL As String, dw As Long
Dim sAddy As String

Set itm = Application.ActiveInspector.CurrentItem
With itm
sStreet = .MailingAddressStreet
sCity = .MailingAddressCity
sState = .MailingAddressState
sZip = .MailingAddressPostalCode
End With

Select Case Map
Case 1:
sAddy = Replace(sStreet & " " & sCity & " " & sState & " " & sZip, "
", "+")
sURL = "http://maps.google.com/maps?q=" & sAddy & "&t=h"
Case 2
sStreet = Replace(sStreet, " ", "+")
sURL =
"http://www.expedia.com/City-Map?action=findAMap@results&findAMap_addressPlace_choice=0&"
& _
"findAMap_addressPlace_country=USA&findAMap_addressPlace_street=" &
sStreet & _
"&findAMap_addressPlace_city=" & sCity &
"&findAMap_addressPlace_state=" & sState & "&findAMap_addressPlace_zip=" &
sZip & _
"&findAMap_addressPlace_placeRegion=0&findAMap_addressPlace_flag=0&findAMap_submitted=1"
Case 3
sURL = "http://mappoint.msn.com/home.aspx?strt1=" & sStreet &
"&city1=" & sCity & "&stnm1=" & sState & "&zipc1=" & sZip
Case 4
sURL = "http://www.mapquest.com/maps/map.adp?address=" & sStreet &
"&city=" & sCity & "&state=" & sState & "&zip=" & sZip
Case 5
sAddy = Replace(sStreet & " " & sCity & " " & sState & " " & sZip, "
", "+")
sURL = "http://maps.yahoo.com/maps_result.php?q1=" & sAddy
End Select


dw = GetDesktopWindow

Call ShellExecute(dw, "open", sURL, vbNullString, vbNullString, 5)

End Sub

'Code End

Matt