Outlook の連絡先から地図検索サイトを呼び出すマクロ Ver 2


コメントで以下のような要望をいただきました。


地図検索サイトを呼び出すマクロのフィールド順を変えて、米国の住所で検索出来るよう試みましたが、うまくいきません。住所がスペースで区切られている場合、スペースの前の部分しか地図検索サイトに引き渡せない様です。


確かに以前公開したマクロでは米国の住所を考慮していませんでした。米国の住所を検索する場合、以下のようなことを考慮する必要があります。

  • 住所の並び順を番地、市町村、都道府県の順にする
  • 住所に含まれるスペースを %20 に置き換える
  • 検索クエリの mkt パラメータに en-us を指定する (Live Search Maps の場合)

そこで、米国の住所でも検索できるようにするようマクロを修正しました。住所の文字列が ASCII 文字のみの場合には米国の住所として認識して検索を実行します。

以下のマクロは連絡先の住所を Google Maps で検索して表示するものです。ブラウザによっては ie=SJIS を ie=UTF-8 にしたり、削除したりする必要があるかもしれません。


' Google Maps を検索するマクロ
' ここをトリプル クリックするとマクロ全体が選択できます。
Sub OpenGoogleMaps()
    Dim objContact As ContactItem
    Dim strAddress As String
    Dim strEncoded As String
    Dim objShell As Object
    Dim i As Integer
    Dim bDbcs As Boolean
    Dim c As String
    Set objContact = Application.ActiveExplorer.Selection.Item(1)
    With objContact
        If .MailingAddress <> "" Then
            bDbcs = False
            For i = 1 To Len(.MailingAddress)
                c = Mid(.MailingAddress, i, 1)
                If Asc(c) > 127 Or Asc(c) < 0 Then
                    bDbcs = True
                End If
            Next
            If bDbcs Then
                strAddress = .MailingAddressState & .MailingAddressCity & .MailingAddressStreet
            Else
                strAddress = .MailingAddressStreet & " " & .MailingAddressCity & " " & .MailingAddressState
            End If
            If strAddress = "" Then
                strAddress = .MailingAddress
            End If
            strEncoded = ""
            For i = 1 To Len(strAddress)
                c = Mid(strAddress, i, 1)
                If c < "0" And c >= " " Then
                    c = "%" & Hex(Asc(c))
                End If
                strEncoded = strEncoded & c
            Next
            Set objShell = CreateObject("WScript.Shell")
            objShell.Run "http://maps.google.co.jp/maps?ie=SJIS&hl=ja&tab=wl&q=&quot; & strEncoded
        End If
    End With
End Sub


また、以下のマクロは Live Search Maps を検索するバージョンです。


' Live Search Maps を検索するマクロ
' ここをトリプル クリックするとマクロ全体が選択できます。
Sub OpenLiveSearchMaps()
    Dim objContact As ContactItem
    Dim c As String
    Dim strAddress As String
    Dim objShell As Object
    Dim i As Integer
    Dim bDbcs As Boolean
    Dim strMkt As String
    Set objContact = Application.ActiveExplorer.Selection.Item(1)
    With objContact
        If .MailingAddress <> "" Then
            bDbcs = False
            For i = 1 To Len(.MailingAddress)
                c = Mid(.MailingAddress, i, 1)
                If Asc(c) > 127 Or Asc(c) < 0 Then
                    bDbcs = True
                End If
            Next
            If bDbcs Then
                strAddress = .MailingAddressState & .MailingAddressCity & .MailingAddressStreet
                strMkt = "ja-jp"
            Else
                strAddress = .MailingAddressStreet & " " & .MailingAddressCity & " " & .MailingAddressState
                strMkt = "en-us"
            End If
            If strAddress = "" Then
                strAddress = .MailingAddress
            End If
            Set objShell = CreateObject("WScript.Shell")
            objShell.Run "http://maps.live.com/?where1=&quot; & Escape(strAddress) & "&mkt=" & strMkt
        End If
    End With
End Sub
' 日本語文字列をエスケープする関数
Function Escape(strText) As String
    Dim strEscaped As String
    Dim c As String
    Dim i As Integer
    For i = 1 To Len(strText)
        c = Mid(strText, i, 1)
        If AscW(c) >= &HFF Or AscW(c) < 0 Then
            c = "%u" & Right("0000" & Hex(AscW(c)), 4)
        ElseIf c < "0" And c >= " " Then
            c = "%" & Hex(Asc(c))
        End If
        strEscaped = strEscaped & c
    Next
    Escape = strEscaped
End Function


マクロの登録方法やメニューへの追加について

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中