VBAで住所録からアイコンを立てるマップを作成してみた



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

taka

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

どうも、お久しぶりです、taka(@takabou63)です(^^♪

すっかりとご無沙汰してしまい申し訳ありません・・・

さて、今回は久しぶりの更新ということで少し張り切った内容になります(笑)

ずばり・・・Yahoo!APIを使用してマップを作成してみた話です(;^ω^)

前にも似たような事を「VBAでGooglemapを使わずに地図を作成(Yahoo!API)」でお話していますがこの時は1つの住所で1つの吹き出しという物でした。

VBAマップイメージ

VBAマップイメージ

ですが、できれば「住所録の住所からアイコンを立てたい」と思うものですよね?(笑)

私はそう思ったので作ってみました(^^)/

久しぶりのプログラムなので少しコードが汚く、苦戦もしてしまいました(;^ω^)

VBAでYahoo! JavaScriptマップAPI で複数のアイコンを立てる

前回と同じく下記のような流れで地図を表示させます

Yahoo!APIを使用したプログラムの関係図

Yahoo!APIを使用したプログラムの関係図

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

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

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

まずは地図のHTMLの原型となるmapdate.txtを用意します。このファイルをVBAで読み込み、VBA内でHTMLに変換して出力します。

mapdate.txtは下記のように作成します。

<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 data = new Array();
    //地図を表示
 var myMap = new Y.Map("map");

    myMap.addControl(new Y.LayerSetControl());
    myMap.addControl(new Y.ZoomControl());
  myMap.drawMap(
    // 中心点緯度経度
      new Y.LatLng(35.605057,  140.123306), 
    // ZOOMレベル
    8,
    // レイヤーセット(標準地図)

    Y.LayerSetId.NORMAL
  );


  for (i = 0; i < data.length; i++) {
    var myMarker = new Y.Marker(data[i].position);
    myMarker.bindInfoWindow(data[i].content);
    myMap.addFeature(myMarker);
  }
}

</script>
</body>
</html>

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

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

今回は表内の住所録を使う予定で作成しましたので住所を記述するテキストボックスは用意しておりません。

コントロール役割
TextBox1YahooAPIキーを入力
CommandButton1実行ボタン
WebBrowser1Yahoo!から得た地図を表示する

地図を表示するコード

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

前回からさらに長くなってしまいましたが、何とか動作はしたました(;^ω^)

途中エラーが発生してしまい、理由の解明がなかなかできなかったのですが、とりあえず「On Error Resume Next」を使って強引にやり過ごすことにしました(;^ω^)

今回はB列に施設名、C列に住所を想定して作成しております、使用した住所のデータもダウンロードできるようにしておりますのでご自由にご使用ください(‘ω’)

最適化できたら随時更新します(;^ω^)

Private Sub CommandButton1_Click()

 'mapdate.txtを元に地図作成のHTMLファイルのデータを作成するーーーーーーーーーーーーーーーーー
    Dim i As Long
    Dim Count As Long  '配列の要素数
    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コードを格納
    Dim jspop2() As String
    Dim hoge() As String '頑張って繰り返す
    Dim lastrow As Long
    Dim UTF8 As String
    Dim Coordinate As String

    
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
FilePath = ThisWorkbook.Path & "\mapdate.txt"
htmlPath = ThisWorkbook.Path & "\map.html"

    
    For i = 2 To lastrow
        ReDim Preserve hoge(i)
        '住所やキーワードをEncodeURL関数を使用してUTF-8に変換
         UTF8 = Application.WorksheetFunction.EncodeURL(Worksheets("Sheet2").Cells(i, 3).Text)
        'UTF-8に変換されたコードをもとに座標を取得
         Coordinate = yahooAddress(UTF8)
        hoge(i) = Coordinate
        DoEvents
    Next i
    
'APIのIDーーーーーーーーーーーーーーー
jsshowcode = "<script src=""https://map.yahooapis.jp/js/V1/jsapi?appid=" & TextBox1.Text & """ type=""text/javascript""  charset=""UTF-8"" ></script>"
'吹き出しーーーーーーーーーーーーーーー
jspop = "var data = new Array();"
  
  '緯度経度と吹き出しを作成するーーーーーーーーーーーーーーー
      For i = 2 To UBound(hoge)
     ReDim Preserve jspop2(i)
      jspop2(i) = "data.push({position: new Y.LatLng(" & hoge(i) & "), content: '" & Cells(i, 2).Text & "'});"
 
     Next i
       
    
'テキストデータからHTMLファイルを作成するーーーーーーーーーーーーーーー
 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
         For i = 0 To UBound(jspop2) '住所の書き出し
         ReDim Preserve strArray(Count)
            strArray(Count) = jspop2(i)
            Count = Count + 1
                 Next i
        End If
Loop

    Close #1

'配列で作成した内容をHTMLファイルに書き出すーーーーーーーーーーーーーーーーー
    With CreateObject("ADODB.Stream") 'UTF-8で出力するためにADODBを使用
        .Charset = "UTF-8"
        .Open
   On Error Resume Next '一定の個所でエラーが発生してしまうのでOn Error Resume Nextを記述。特定次第削除
    For i = 0 To UBound(strArray) '配列strArray すべてを書き出し
       .WriteText strArray(i), 1
    Next i
        .SaveToFile htmlPath, 2  '上書き保存、ファイルがなければ新規作成
        .Close
    End With

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

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