LoginSignup
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@Q11Q

Excel VBA 国土地理院のAPIを使って緯度経度から標高を取得する

Last updated at Posted at 2025-03-01

前提

  • A1: 経度
  • B1: 緯度
  • C1: 標高（m 単位）
  • D1: 精度（メッシュ、測量方法）
  • F1: 関数で取得した標高（m 単位）
A1,B1の緯度経度の場所の標高がC１、F1に入って来る。

特徴

  • GeoJSON を パースする必要がない ため、外部モジュールの導入は不要。
  • シンプルな処理で標高を取得可能。

Geojsonの例

東京都庁を取得してみます

{"elevation":39.8,"hsrc":"5m\uff08\u30ec\u30fc\u30b6\uff09"}
  • `"elevation"` の値 39.8 が標高（m 単位、小数点以下 1 桁まで取得可能）。
  • `"hsrc"` の `"5m"` は 5m メッシュ。
  • `"hsrc"` の `\uff08\u30ec\u30fc\u30b6\uff09` は エスケープされた Unicode で「（レーザ）」 を意味する。

39.8が標高です。m単位です。小数点以下はおおむね１桁まで取得できます。
5ｍが5mメッシュ
そしてそのあとがエスケープ付きでユニコードです。ここは（レーザ）となっています。
ということは入れ子構造ではないので、簡単に標高は取得できます。
Dictionaryを使っていますが、それも使わなくても正規表現でも取得できます。

緯度経度の小数点以下

  • 小数点以下 6 桁が有効範囲（測位誤差を考慮）。
  • 最大 8 桁まで保持すれば十分な精度を確保可能。

度分秒を 10 進数に変換する共通関数

以下の Sub / Functionで、「北緯 35度21分38秒」などの度分秒(DMS)形式のセルの値を 10 進数に変換する関数。

Function ConvertDMS_To_Decimal(degrees As Double, minutes As Double, seconds As Double) As Double
    ConvertDMS_To_Decimal = degrees + (minutes / 60) + (seconds / 3600)
End Function

Sub のコード

Microsoft Scripting Runtimeを参照設定してください

Sub GetElevation()
    Dim http As Object
    Dim lat As String, lon As String
    Dim url As String
    Dim responseText As String
    Dim elevation As String
    Dim regex As Object, M, MC, iM As Long
    Dim l1 As Double, l2 As Double, l3 As Double
    Dim DecodeString As String
    Dim unicodeHex As String
    Dim unicodeChar  As String
    Dim keyValues As Variant
    Dim dict As New Scripting.Dictionary
    Set regex = CreateObject("VBScript.RegExp")
' Excelのセルから緯度・経度を取得（A1に経度、B1に緯度）
    lon = Range("A1").value
    lat = Range("B1").value
' 度分秒くらいは変換
    If lat Like "*度*" Then
    lat = Replace(lat, "北緯", "", 1, -1, vbTextCompare)
    lat = Replace(lat, " ", "", 1, -1, vbTextCompare)
    l1 = Mid(lat, 1, 2)
    l2 = Mid(lat, 4, 2)
    l3 = Replace(Mid(lat, 7, Len(lat)), "秒", "", 1, -1, vbTextCompare)
    lat = ConvertDMS_To_Decimal(l1, l2, l3)
    End If
    If lon Like "*度*" Then
    lon = Replace(lon, "東経", "", 1, -1, vbTextCompare)
    lon = Replace(lon, " ", "", 1, -1, vbTextCompare)
    l1 = Mid(lon, 1, 3)
    l2 = Mid(lon, 5, 2)
    l3 = Replace(Mid(lon, 8, Len(lon)), "秒", "", 1, -1, vbTextCompare)
    lon = ConvertDMS_To_Decimal(l1, l2, l3)
    End If
    
' 緯度経度の入力チェック
    If Not IsNumeric(lat) Or Not IsNumeric(lon) Then
        MsgBox "経度または緯度が無効です。", vbExclamation
        Exit Sub
    End If
    
' 国土地理院の標高APIエンドポイント
    url = "https://cyberjapandata2.gsi.go.jp/general/dem/scripts/getelevation.php?" & _
          "lat=" & lat & "&lon=" & lon

' HTTPリクエストの送信
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.Send

' API レスポンスの処理
    If http.Status <> 200 Then
        MsgBox "API リクエストが失敗しました。ステータスコード: " & http.Status, vbExclamation
        Exit Sub
    End If
    jsonResponse = http.responseText

' Unicode文字列を変換
    With regex
    .Global = True
    .IgnoreCase = True
    .Pattern = "\\u([0-9A-Fa-f]{4})" ' \uXXXX の形式を検索
    Set MC = .Execute(jsonResponse)
    End With
    If MC.Count > 0 Then
        For Each M In MC
        unicodeHex = M.SubMatches(0)
        unicodeChar = ChrW("&H" & unicodeHex)  ' 16進数をUnicode文字に変換
        jsonResponse = Replace(jsonResponse, M.value, unicodeChar, 1, -1, vbBinaryCompare)
        Next
    End If

' 配列になるようにタグを置換
    jsonResponse = Replace(jsonResponse, "{", "")
    jsonResponse = Replace(jsonResponse, "}", "")
    jsonResponse = Replace(jsonResponse, ",", vbCrLf)
    jsonResponse = Replace(jsonResponse, ":", ",")
    jsonResponse = Replace(jsonResponse, """", "")

' 配列に代入
    keyValues = Split(jsonResponse, vbCrLf)
' 連想配列に代入
    For iM = 0 To UBound(keyValues)
    dict.Add Split(keyValues(iM), ",")(0), Split(keyValues(iM), ",")(1)
    Next

   Range("C1") = dict.Items(0)
   Range("D1") = dict.Items(1)
    ' 後処理
    Set http = Nothing
    Set regex = Nothing
End Sub

関数

Microsoft Scripting Runtimeを参照設定してください

'********************************************************
'* 関数名　fnGetElevation
'* 変数 lon lat 返り値 double
'* 目的 国土地理院のAPIを活用し、緯度と経度から標高を求める
'*********************************************************
Function fnGetElevation(lon, lat) As Double
Function fnGetElevation(lon, lat) As Double
    Dim http As Object
    Dim url As String
    Dim responseText As String
    Dim elevation As String
    Dim regex As Object, M, MC, iM As Long
    Dim l1 As Double, l2 As Double, l3 As Double
    Dim DecodeString As String
    Dim unicodeHex As String
    Dim unicodeChar  As String
    Dim keyValues As Variant
    Dim dict As New Scripting.Dictionary

    Set regex = CreateObject("VBScript.RegExp")
    ' Excelのセルから緯度・経度を取得（A1に経度、B1に緯度）
    '
    If lat Like "*度*" Then
    lat = Replace(lat, "北緯", "", 1, -1, vbTextCompare)
    lat = Replace(lat, " ", "", 1, -1, vbTextCompare)
    l1 = Mid(lat, 1, 2)
    l2 = Mid(lat, 4, 2)
    l3 = Replace(Mid(lat, 7, Len(lat)), "秒", "", 1, -1, vbTextCompare)
    lat = ConvertDMS_To_Decimal(l1, l2, l3)
    End If
    If lon Like "*度*" Then
    lon = Replace(lon, "東経", "", 1, -1, vbTextCompare)
    lon = Replace(lon, " ", "", 1, -1, vbTextCompare)
    l1 = Mid(lon, 1, 3)
    l2 = Mid(lon, 5, 2)
    l3 = Replace(Mid(lon, 8, Len(lon)), "秒", "", 1, -1, vbTextCompare)
    lon = ConvertDMS_To_Decimal(l1, l2, l3)
    End If

    ' 緯度経度の入力チェック
    If Not IsNumeric(lat) Or Not IsNumeric(lon) Then
        MsgBox "経度または緯度が無効です。", vbExclamation
        Exit Function
    End If
    
    
    ' 国土地理院の標高APIエンドポイント
    url = "https://cyberjapandata2.gsi.go.jp/general/dem/scripts/getelevation.php?" & _
          "lat=" & lat & "&lon=" & lon
    ' HTTPリクエストの送信
    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.Send
    ' API レスポンスの処理
    If http.Status <> 200 Then
        MsgBox "API リクエストが失敗しました。ステータスコード: " & http.Status, vbExclamation
        Exit Function
    End If
    jsonResponse = http.responseText
        
    ' Dictionary に変換


    With regex
    .Global = True
    .IgnoreCase = True
    .Pattern = "\\u([0-9A-Fa-f]{4})" ' \uXXXX の形式を検索
    Set MC = .Execute(jsonResponse)
    End With
    If MC.Count > 0 Then
        For Each M In MC
        unicodeHex = M.SubMatches(0)
        unicodeChar = ChrW("&H" & unicodeHex)  ' 16進数をUnicode文字に変換
        jsonResponse = Replace(jsonResponse, M.value, unicodeChar, 1, -1, vbBinaryCompare)
        Next
    End If
    
    jsonResponse = Replace(jsonResponse, "{", "")
    jsonResponse = Replace(jsonResponse, "}", "")
    jsonResponse = Replace(jsonResponse, ",", vbCrLf)
    jsonResponse = Replace(jsonResponse, ":", ",")
    jsonResponse = Replace(jsonResponse, """", "")


    keyValues = Split(jsonResponse, vbCrLf)
    For iM = 0 To UBound(keyValues)
    dict.Add Split(keyValues(iM), ",")(0), Split(keyValues(iM), ",")(1)
    Next
    fnGetElevation = dict.Items(0)
    ' 後処理
    Set http = Nothing
    Set regex = Nothing
End Function
0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
0
0

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?