VBAでGooglemapを使わずに地図を作成(Yahoo!API)



The following two tabs change content below.
アバター

taka

あることがキッカケでVBAを独学で勉強しました、今ではブログを通してVBAでできることを解説しつつ、VBAや他の言語の勉強、ブログ運営の勉強をしています(^^♪

どうも、taka(@takabou63)です(^^♪

さて、最近VBAの記事を書いていなかったのでネタを探していたら「Googlemap使えてなくないか?」ということに気が付きました(*_*;
参考:「ExcelVBAとGoogleマップの連携2

恐らくGoogleAPIの仕様(無料が有料化「実質無料」)が変更になったことが原因だと思うのですが・・・

GoogleAPIは登録とかが面倒そうだったので今回は「Yahoo! JavaScriptマップAPI」を使用して「ExcelVBAとGoogleマップの連携2」と同じような地図を作成してみようかと思います(^^♪

VBAでYahoo! JavaScriptマップAPI 地図を表示する手順

まずYahoo!マップを表示する為に必要な準備をしていきましょう。用意するものは以下のものです(^.^)

  1. 地図作成VBAファイル(ユーザーフォームも作成する) yhoomap.xlsm
  2. HTMLファイルを作成するためその元となるデータ  mapdate.txt
  3. Yahoo!APIキー【Yahoo!APIキーを取得はこちらから、取得方法は「VBA 郵便番号から住所を取得する方法」で紹介しています。】

この後、yhoomap.xlsmでHTMLファイルを作成しますがとりあえずはこの3つを用意します。

地図ファイルの元になるtxtファイルを用意する

mapdate.txtは下記のように作成します。このファイルをVBAで読み込み、HTMLに変換して出力します。

<html>
<head>
<meta http-equiv="Content-Type" content="text/html" charset="UTF-8">
<title>地図を表示する - YOLP JavaScriptマップAPI サンプルコード</title>


</head>
<body>
  <div id="map" style="width:600px; height:480px;"></div>

<!-- Begin Yahoo! JAPAN Web Services Attribution Snippet -->
<a href="https://developer.yahoo.co.jp/about">
<img src="https://s.yimg.jp/images/yjdn/yjdn_attbtn2_105_17.gif" width="105" height="17" title="Webサービス by Yahoo! JAPAN" alt="Webサービス by Yahoo! JAPAN" border="0" style="margin:15px 15px 15px 15px"></a>
<!-- End Yahoo! JAPAN Web Services Attribution Snippet -->


<script >
<!--
window.onload = function() {
    //地図を初期化
    var map = new Y.Map("map");

    //コントロールの追加
    map.addControl(new Y.LayerSetControl());
    map.addControl(new Y.ZoomControl());

    //地図を表示

}
//-->
</script>
</body>
</html>

地図表示するユーザーフォームを用意する

地図を表示する為のフォームを作成します。用意するのは下記のコントロールです(^.^)

コントロール役割
TextBox1YahooAPIキーを入力
TextBox2出発地の住所やキーワードを入力
TextBox3取得した出発地の座標を表示
TextBox4出発地住所をもとにUTF-8エンコードした文字列を表示
CommandButton1取得した座標をもとにYahoo!へリクエストを送る
WebBrowser1Yahoo!から得た地図画像を表示する

地図を表示するコード

地図を作成するコードは以下のようにしました(*_*;

私も慣れない処理だったので長くなってしまいました(*_*;もう少し最適化できれば随時更新します(;^ω^)

下記のコードは下記の二つの処理を行っています。

  1. 地図表示のHTMLを作成するコード
  2. 住所を元に座標をYahoo!にリクエストするコード

下にファイルのダウンロードを置いて置きますので好きに変えて使用してください(笑)

Option Explicit
Private Sub CommandButton1_Click()
'mapdate.txtを元に地図作成のHTMLファイルのデータを作成するーーーーーーーーーーーーーーーーー
    Dim i As Integer
    Dim Count As Integer  '配列の要素数
    Dim strBuff As String 'mapdateの内容を格納
    Dim strArray() As String  'mapdateの内容を格納する配列
    Dim FilePath As String    'mapdate.txtのファイル位置
    Dim htmlPath As String    'map.htmlのファイル位置
    Dim jsshowcode As String  '地図を表示するためのjsコードを格納(APIキー)
    Dim jscode As String        '座標のjsコードを格納
    Dim jspop As String          '吹き出しを表示させるためのjsコードを格納

FilePath = ThisWorkbook.Path & "\mapdate.txt"
htmlPath = ThisWorkbook.Path & "\map.html"

jsshowcode = "<script src=""https://map.yahooapis.jp/js/V1/jsapi?appid=" & TextBox1.Text & """ type=""text/javascript""  charset=""UTF-8"" ></script>"
jscode = "map.drawMap(new Y.LatLng(" & TextBox3.Text & "), 16 ,Y.LayerSetId.NORMAL);"
jspop = "map.openInfoWindow(map.getCenter(), """ & TextBox2.Text & """);"
 
 Open FilePath For Input As #1
  Do Until EOF(1)
     Line Input #1, strBuff          ' ファイルから一行読み込み
     
     ReDim Preserve strArray(Count)   ' 配列長を変更
       If InStr(strBuff, "<title>") = 0 Then 'jsshowcodeを挿入する位置を判定
          strArray(Count) = strBuff        ' 配列の最終要素に読み込んだ値を代入
          Count = Count + 1             ' 配列の要素数を加算
      Else
          strArray(Count) = strBuff
          Count = Count + 1
          ReDim Preserve strArray(Count)
          strArray(Count) = jsshowcode
          Count = Count + 1
      End If
   
        If InStr(strBuff, "//地図を表示") = 0 Then 'jscode、jspop挿入する位置を判定
        Else
         ReDim Preserve strArray(Count)
            strArray(Count) = strBuff
            Count = Count + 1
         ReDim Preserve strArray(Count)
            strArray(Count) = jscode
            Count = Count + 1
         ReDim Preserve strArray(Count)
            strArray(Count) = jspop
            Count = Count + 1
        End If
Loop
    
    Close #1
    
'配列で作成した内容をHTMLファイルに書き出すーーーーーーーーーーーーーーーーー
    With CreateObject("ADODB.Stream") 'UTF-8で出力するためにADODBを使用
        .Charset = "UTF-8"
        .Open
    For i = 0 To UBound(strArray) '配列strArray すべてを書き出し
       .WriteText strArray(i), 1
    Next i
        .SaveToFile htmlPath, 2  '上書き保存、ファイルがなければ新規作成
        .Close
    End With

WebBrowser1.Navigate htmlPath 'ユーザーフォームに出力

    

End Sub
Private Sub TextBox2_Change()
'住所やキーワードをEncodeURL関数を使用してUTF-8に変換
TextBox4.Text = Application.WorksheetFunction.EncodeURL(TextBox2.Value)
End Sub
Private Sub TextBox4_Change()
'UTF-8に変換されたコードをもとに座標を取得
TextBox3.Text = yahooAddress(TextBox4.Text)
End Sub
Function yahooAddress(ByRef Addresscode As String)
'YahooAPIを使って緯度・経度を取得する関数
Dim XMLArr
Dim start As Long
Dim goal As Long
Dim objHttp As Object
Set objHttp = CreateObject("MSXML2.XMLHTTP")

     '↓GETリクエストをヤフーに送る
    objHttp.Open "GET", "https://map.yahooapis.jp/geocode/cont/V1/contentsGeoCoder?appid=" & TextBox1.Text & "&query=" & Addresscode, False
    objHttp.Send
    'responseTextでレスポンスを取得
   XMLArr = objHttp.responseText
  '座標が格納されている<Coordinates>の間のデータを取得
  start = InStr(XMLArr, "<Coordinates>")
  goal = InStr(XMLArr, "</Coordinates>")
    '<Coordinates>がない場合の処理
  If start = 0 Or goal = 0 Then '
   GoTo skip
  End If
        
 '取得した位置の間の文字をMid関数で抜き出す
  XMLArr = Mid(XMLArr, start + 13, goal - start - 13)
  '緯度経度の順番を入れ替えたいので一度配列に格納
  XMLArr = Split(XMLArr, ",")
  '緯度経度の順番を入れ替える
  yahooAddress = XMLArr(1) & "," & XMLArr(0)

skip:
End Function

ダウンロード

当サイトの免責事項をお読みになってからお使いください。

 

フォロー・チャンネル登録お願いします

VBA以外についてのブログはこちら↓

https://yb-log.com/

■Twitterフォロー

■YouTubeチャンネル登録

ファイルやコードの利用、WEBサイトの利用について

サンプルコードなどは当サイトの免責事項をよくお読みになってからお使いください。

Sponsored Link

 

WordPressでブログを始めるなら

WordPress簡単インストール&安心の安定性

レンタルサーバー Xserver