Private Sub CommandButton1_Click()
'取得した座標をもとに、WebBrowserコントロールに地図の画像を表示させる
WebBrowser1.Navigate "https://map.yahooapis.jp/course/V1/routeMap?appid=" & TextBox1.Value & _
"&route=" & TextBox3.Text & "," & TextBox6.Text & "&width=600&height=500"
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
コメントを残す