VBA使用頻度の高いコード（１３）：Exif情報読込２（GPSExifReaderのクラスモジュールを使った場合）

Exif情報読込２（GPSExifReaderのクラスモジュールを使った場合）

Exif情報読込２（GPSExifReaderのクラスモジュールを使った場合）です。Access用GPSクラスモジュールが必要です。（以下のサイトからダウンロード）

www.everythingaccess.com

使い方は以下のサイト

Excel(VBA)でJPGファイルのExif情報を読み込む – FRONT

Excelで使い場合はインスタンスの呼び出しが必要になります。

以下のコードはリスト上の写真から緯度経度情報を一括で記述するコードです。

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub 入力準備()
'写真情報取込み出力
On Error Resume Next ' エラー時は強制で次に以降

Dim ER '＜－－インスタンス　Exif用クラスより入手
Dim ctRow, i As Long
Dim nameID, pkupDate, ckDate, ckDate1 As String
Dim nameArea, nameFolder, pkupArea, ckCategory As String
Dim pkupLon, pkupLat

'名前初期値
nameID = Range("C8")

'GPSクラスインスタンス格納
Set ER = New GPSExifReader

For ctRow = 10 To 20000
FilePath = Range("B" & ctRow)
If (FilePath = "") Then
Exit For
End If
i = i + 1
Range("C" & ctRow) = nameID & i '画像ID
pkupDate = ""
If (Range("A" & ctRow) = "") Then 'チェック欄空欄でのときのみ処理

With ER.Openfile(FilePath) '画像より情報抽出
Range("D" & ctRow) = .DateTimeOriginal '日時
pkupDate = .DateTimeOriginal
ckDate = Replace(pkupDate, ":", "")
ckDate1 = Replace(ckDate, " ", "")
If (ckDate1 = "") Then '日時→日付のみ抽出
Range("G" & ctRow) = "日付無"
Else
Range("G" & ctRow) = Left(ckDate, 8)
End If
Range("E" & ctRow) = .GPSLatitudeDecimal '緯度
Range("F" & ctRow) = .GPSLongitudeDecimal '経度
End With '緯度経度データからエリア作成⇒指定誤差範囲

If (Range("K" & ctRow) = "") Then '事前に入っている値を優先する
If (Range("E" & ctRow) = "" Or Range("F" & ctRow) = "") Then
Range("H" & ctRow) = "地域無" '緯度経度データない場合事前に「地域無」代入
Range("K" & ctRow) = Right(Range("G" & ctRow), 4) & "_" & Range("C" & ctRow) & "_無_無" 'ファイル名⇒日時(4桁)_ID_無_無.jpg
ActiveSheet.Hyperlinks.Add Anchor:=Range("L" & ctRow), Address:="https://www.google.co.jp/maps,ScreenTip:=" & "緯地図", TextToDisplay:="https://www.google.co.jp/maps"
Else
Range("K" & ctRow) = Right(Range("G" & ctRow), 4) & "_" & Range("C" & ctRow) & "_" & Range("E" & ctRow) & "_" & Range("F" & ctRow) 'ファイル名⇒日時(4桁)_ID_緯度_経度.jpg
ActiveSheet.Hyperlinks.Add Anchor:=Range("L" & ctRow), Address:="https://www.google.co.jp/maps/@" & Range("E" & ctRow) & "," & Range("F" & ctRow) & ",72m/data=!3m1!1e3,ScreenTip:=" & Range("E" & ctRow) & "緯度" & Range("F" & ctRow) & "経度地図", TextToDisplay:="https://www.google.co.jp/maps/@" & Range("E" & ctRow) & "," & Range("F" & ctRow) & ",72m/data=!3m1!1e3"
End If
End If
End If
Next ctRow

ER = Nothing

End Sub

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝