2018年09月: 森林土木memo

<< 2018年08月 | TOP | 2018年10月 >>

2018年09月19日

緯度経度付きJpegから緯度経度付きのCSVを作る

注意！この記事はかなり古い情報です。現在のQGISとは操作方法が違いますので注意してください

QGISのPhoto2Shapeがうまく動かないという時があるようで、いざ使おうとしたときに使えなかったら困りますね。

そこで、Excelで緯度経度付きのJpegファイルを読み込んで、緯度経度付きのCSVファイルを作るExcelファイルを作成しました。

このファイルで、Jpegを保存しているフォルダを指定すると、写真のExif情報を読み込んで一覧を作成します。

その一覧表をCSVに保存します。

作成された緯度経度付きのCSVは、QGISのデリミティッドテキストレイヤで読み込めば、ポイントレイヤが作成されます。

Jpegファイルのフォルダ名、ファイル名も記録されているので、eVisプラグインで写真を表示することも可能です。

もしPhoto2shapeプラグインがうまく動かないというときは活用していただければと思います。

Photo2Excel2CSV_V002.zip

以下、VBAのコードも記録しておきます。

このコードを作成するのに、参考にしたサイトはここです。先人の知恵に感謝します。

Option Explicit

Sub wiaImage()
'ファイル一覧取得
Dim D_fileName As String
Dim D_count As Long
Dim D_folderName As String
Dim x As Object 'WIA.ImageFile
Dim p As Variant
Dim i As Integer
Dim D_id As Long

D_count = 0

Worksheets("JPEG一覧").Cells.ClearContents 'セルの内容消去

'フォルダ指定
MsgBox "位置情報付きのJpegファイルが保存されているフォルダを指定してください。", vbInformation
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
D_folderName = .SelectedItems(1)
End If
End With
'ファイル一覧を取得
D_fileName = Dir(D_folderName & "\*.jpg")

'列名を入力
Worksheets("JPEG一覧").Cells(1, 1) = "FolderName"
Worksheets("JPEG一覧").Cells(1, 2) = "FileName"

Do While D_fileName <> ""
i = 0
D_count = D_count + 1
Worksheets("JPEG一覧").Cells(D_count + 1, 1) = D_folderName & "\" 'フォルダ名を記入
Worksheets("JPEG一覧").Cells(D_count + 1, 2) = D_fileName 'ファイル名を記入

'exif情報をコピー
Set x = CreateObject("Wia.ImageFile")
x.LoadFile D_folderName & "\" & D_fileName

On Error Resume Next

'Exif情報を記入
For Each p In x.Properties
i = i + 1
D_id = p.propertyid
Worksheets("JPEG一覧").Cells(1, i + 2).Value = p.Name '列名を記入
If p.propertyid = 2 Or p.propertyid = 4 Then
Worksheets("JPEG一覧").Cells(D_count + 1, i + 2).Value = getGPS(p) 'GPS情報の場合、度分秒を結合して10進数に変更
Else
Worksheets("JPEG一覧").Cells(D_count + 1, i + 2).Value = p.Value
End If
Next
On Error GoTo 0

Set x = Nothing

D_fileName = Dir() 'ファイル名をクリア

Loop

Worksheets("JPEG一覧").Select

Call CSV出力

Worksheets("メイン").Select

End Sub

’＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Function getGPS(p As Variant) As Double
getGPS = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600
End Function

’＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub CSV出力()

Dim D_ws As Worksheet
Set D_ws = ThisWorkbook.Worksheets(2)

MsgBox "CSVファイルの保存先を指定してください。", vbInformation

Dim D_csvFilepath As String
'ファイル指定ダイアログ
D_csvFilepath = Application.GetSaveAsFilename(Title:="CSVファイルの保存先", Filefilter:="CSVファイル,*.csv")

'CSVファイルを作成
Open D_csvFilepath For Output As #1

Dim gyou As Long
Dim retu As Long
Dim D_Data

'CSVへ書きだし
gyou = 1
Do While D_ws.Cells(gyou, 1).Value <> ""
retu = 1
Do While D_ws.Cells(1, retu + 1).Value <> ""
D_Data = D_ws.Cells(gyou, retu).Value
Print #1, D_Data & ","; 'データを記入
retu = retu + 1
Loop
Print #1, D_ws.Cells(gyou, retu).Value & vbCrLf; '改行コードを記入
gyou = gyou + 1
Loop

Close #1

MsgBox "CSVファイルを保存しました。確認してください。"

End Sub

posted by kouichi at 23:43| Comment(0) | QGIS |