VBAで、逆ジオコーティングしたく、WEBの記事を参考に下記のソースを書きました。
しかし、計算したあとの経度・緯度が少しずれてしまいます。
何が原因か教えて頂けませんでしょうか。数学がさっぱりなので調べてもよくわからず、申し訳ありませんが、お力を貸して頂けませんでしょうか
写真のEXIF情報
下記のソースを実行した結果
'*********************************************************
' 指定フォルダ内のファイル名一覧を取得
'*********************************************************
Private Sub データ取得ボタン()
Const cnsTitle = "一覧データ取得"
Const cnsDIR = "*.*"
Dim xlAPP As Application
Dim strPath As String
Dim strFilename As String
Dim GYO As Long
Dim row As Long
Dim photFile As String
Dim objWia As Object
Dim p As Object
Dim makerName As String
Dim ModelName As String
Dim dateOfShooting As String
Dim latitude As String
Dim longitude As String
Dim alongitude As String
Dim a As String
Rows("14:" & Cells.Rows.Count).Delete
Set xlAPP = Application
' フォルダの場所を指定する
strPath = Range("D1").Value
' フォルダの存在確認 --- 必要な場合のみ記述 ---
If Dir(strPath, vbDirectory) = "" Then
MsgBox "画像フォルダの場所を選択してください。", vbExclamation, cnsTitle
Exit Sub
End If
' 先頭のファイル名の取得
strFilename = Dir(strPath & cnsDIR, vbNormal)
' ファイルが見つからなくなるまで繰り返す
GYO = 13
Do While strFilename <> ""
' 行を加算
GYO = GYO + 1
Cells(GYO, 3).Value = strFilename
' 次のファイル名を取得
strFilename = Dir()
Loop
GYO = 14
' '写真(画像ファイル)をロード
Do While Cells(GYO, 3).Value <> ""
If Cells(GYO, 3).Value = "" Then Exit Do
photFile = Cells(1, 4).Value & "\" & Cells(GYO, 3).Value
Set objWia = CreateObject("Wia.ImageFile")
objWia.LoadFile photFile
For Each p In objWia.Properties
Select Case p.Name
'撮影日時
Case "ExifDTOrig"
row = 2
dateOfShooting = Format(Replace(p.Value, ":", ""), "@@@@年@@月@@日@@@時@@分@@秒")
Cells(GYO, row).Value = dateOfShooting
'緯度
Case "GpsLatitude"
row = 8
latitude = p.Value(1) + (p.Value(2) / 60) + p.Value(3) / 3600
Cells(GYO, row).Value = latitude
'経度
Case "GpsLongitude"
row = 9
longitude = p.Value(1) + (p.Value(2) / 60) + p.Value(3) / 3600
Cells(GYO, row) = longitude
End Select
Next
GYO = GYO + 1
row = row + 1
photFile = Cells(1, 4).Value & "\" & Cells(GYO, row).Value
' 行を加算
Loop
Call 距離の計算
End Sub
Sub 距離の計算()
Dim myRange As Range
Dim myObj As Range
Dim keyWord As String
Dim hit As String
Dim ido1 As String
Dim keido1 As String
Dim latitude1 As Double
Dim longitude1 As Double
Dim latitude2 As Double
Dim longitude2 As Double
Dim gyo2 As String
If Range("C6").Value <> "" Then
Set myRange = Range("C14:C500")
keyWord = Range("C6").Value
Set myObj = myRange.Find(keyWord, LookAt:=xlWhole)
If myObj Is Nothing Then
' MsgBox "'" & keyWord & "'はありませんでした"
Else
hit = myObj.row
ido1 = Cells(hit, 8).Value
keido1 = Cells(hit, 9).Value
latitude1 = ido1
longitude1 = keido1
gyo2 = 14
'緯度が空欄になるまで繰り返す
Do While Cells(gyo2, 8).Value <> ""
If Cells(gyo2, 8).Value = "" Then Exit Do
latitude2 = Cells(gyo2, 8).Value
longitude2 = Cells(gyo2, 9).Value
If (latitude1 <> latitude2) And (longitude1 <> longitude2) Then
Call Get_GeoDistance(latitude1, longitude1, latitude2, longitude2)
Cells(gyo2, 7).Value = Round(Get_GeoDistance(latitude1, longitude1, latitude2, longitude2), 2)
Else
Cells(gyo2, 7).Value = 0
End If
gyo2 = gyo2 + 1
Loop
End If
End If
End Sub
'***********************************************************************
' [引 数] lat1:地点1緯度 lng1:地点1経度 lat2:地点2緯度 lng2:地点2経度
' [戻り値] なし
'***********************************************************************
'緯度、経度の十進数表記からラジアンに変換します。
'引数1：緯度又は経度
'戻り値：ラジアン
Function DegToRad(deg As Double) As Double
DegToRad = deg * Pi / 180
End Function
'引数で渡された二地点の緯度、経度から距離を返します。
'引数1：緯度(地点1)
'引数2：経度(地点1)
'引数3：緯度(地点2)
'引数4：経度(地点2)
'戻り値：距離(キロメートル単位)
Function Get_GeoDistance(latitude1 As Double, longitude1 As Double, latitude2 As Double, longitude2 As Double) As Double
Dim formula1 As Double
Dim formula2 As Double
Dim formula3 As Double
'式が長いので分割します。
formula1 = Math.Cos(DegToRad(latitude1)) * Math.Cos(DegToRad(latitude2))
formula2 = Math.Cos((DegToRad(longitude2)) - (DegToRad(longitude1)))
formula3 = Math.sin(DegToRad(latitude1)) * Math.sin(DegToRad(latitude2))
Get_GeoDistance = ArcCos(formula1 * formula2 + formula3) * EarthRadius
End Function
'Excelのシート内関数にはあるが、VBAにはACOS関数が無いので自作します。
Function ArcCos(X) As Double
ArcCos = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
End Function
