VBAで経路を取得する地図を作成してみた



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

taka

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

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

さて、最近よく「YahooAPI」を使用した地図を趣味で作っていたりするわけですが、皆さんのお役に立てているのか正直不安な今日この頃・・・(笑)

さて、今回もそんなYahooAPIを使用して「経路を取得できる地図」を作成してみたという記事になります(^.^)
前にも『VBA YahooAPIを使って2つの場所の経路を取得してみた』という似たような記事を作成したのですが、あれは『画像の地図』だったんですよね(;・∀・)
なので表示される経路もなんかさみしい感じで、しかも動かすことができないので不便・・・

YahooAPI画像地図イメージ

YahooAP『I画像』地図イメージ

このように経路の部分しか地図も表示されないものでした。

なので今回は『VBAで住所録からアイコンを立てるマップを作成してみた』で使用したようなjavascriptを使用した地図を使って、VBAのユーザーフォーム上に経路地図を表示させてみます(‘ω’)

今回作成したVBA経路地図イメージ

今回作成したVBA経路地図イメージ

余りにもニッチな内容ですので読者の方が置いてけぼりにならないか心配ですがどうかお付き合いください(笑)

VBAで『Yahoo! JavaScriptマップAPI』を使用して経路地図を作る

毎度同じみ、この説明

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

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

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

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

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

今回は経路地図ですので、前回使用したmapdate.txtは使用できません。

今回のmapdate.txtは下記のようにします。

参考:『Yahoo! JavaScriptマップAPIで経路検索プラグインを使い、初期表示で経路を表示する

<html>
<head>
<title>経路を表示する</title>
</head>
<body>
<div id="map" style="width:500px; height:500px;"></div>


<script type="text/javascript">
window.onload = function() {
    var map = new Y.Map("map",{"configure":{"scrollWheelZoom":true}});
    map.addControl(new Y.LayerSetControl());
    map.addControl(new Y.SliderZoomControlHorizontal());
    map.addControl(new Y.CenterMarkControl());
    var configs = {
        "latlngs": [


        ]
    };

   
    var plugin = new Y.RouteSearchPlugin(configs);

    map.drawMap(new Y.LatLng(35.662484, 139.734222), 15 , Y.LayerSetId.NORMAL);

    map.addPlugin(plugin);
}
</script>
</body>
</html>

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

今回は経路地図なので前に『VBA YahooAPIを使って2つの場所の経路を取得してみた』で使用したフォームをそのまま流用しました(笑)面倒だったから・・・

経路地図フォーム

経路地図フォーム

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

VBAで経路地図を表示させるサンプルコード

今回のサンプルコードは『VBAで住所録からアイコンを立てるマップを作成してみた』で使用した内容を改変して作成しました。

今回は急ごしらえで作成しましたので、不細工な内容があるかもしれません、もし何かありましたらコメントか何かで「やさしく指摘」してください(笑)

ダウンロードファイルは下にありますので気軽にどうぞ。

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 UTF8 As String
Dim routeStart As String
Dim routeGoal As String

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


'APIのIDーーーーーーーーーーーーーーー
jsshowcode = "<script src=""https://map.yahooapis.jp/js/V1/jsapi?appid=" & TextBox1.Text & """ type=""text/javascript""  charset=""UTF-8"" ></script>"
'発着の経度緯度ーーーーーーーーーーーーーーー
routeStart = "new Y.LatLng(" & TextBox3.Value & "),"
routeGoal = "new Y.LatLng(" & TextBox6.Value & ")"
'テキストデータから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, """latlngs"": [") = 0 Then '経路座標を入力する位置を指定
Else
ReDim Preserve strArray(Count)
strArray(Count) = routeStart & vbCrLf & routeGoal
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 TextBox5_Change()
'住所やキーワードをEncodeURL関数を使用してUTF-8に変換
TextBox7.Text = Application.WorksheetFunction.EncodeURL(TextBox5.Value)
End Sub
Private Sub TextBox4_Change()
'UTF-8に変換されたコードをもとに座標を取得
TextBox3.Text = yahooAddress(TextBox4.Text)
End Sub
Private Sub TextBox7_Change()
'UTF-8に変換されたコードをもとに座標を取得
TextBox6.Text = yahooAddress(TextBox7.Text)
End Sub
Function yahooAddress(Addresscode As String)
'YahooAPIを使って緯度・経度を取得する関数
Dim XMLArr
Dim Start As Long
Dim Goal As Long
'Dim objHttp As XMLHTTP60 '【Microsoft XML, v6.0】を参照設定してある場合はこれで
Set objHttp = New XMLHTTP60 '【Microsoft XML, v6.0】を参照設定してある場合はこれで

'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