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.Cle
'フォルダ指定
MsgBox "位置情報付きのJpegファイルが保存されているフォルダを指
With Application.FileDialog(msoFile
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_c
Worksheets("JPEG一覧").Cells(D_c
'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_c
Else
Worksheets("JPEG一覧").Cells(D_c
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
Dim D_ws As Worksheet
Set D_ws = ThisWorkbook.Worksheets(2)
MsgBox "CSVファイルの保存先を指定してください。", vbInformation
Dim D_csvFilepath As String
'ファイル指定ダイアログ
D_csvFilepath = Application.GetSaveAsFilename(
'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