将多个图像的纬度/经度生成到电子表格中

Question

我需要使用带有以下字段的Excel创建照片日志： 文件名，大小，项目类型，拍摄日期，相机型号，纬度，经度，海拔高度

下面的代码可以很好地获取文件名，大小，项目类型，拍摄日期和相机型号。我需要有关纬度，经度和海拔的帮助。我在该网站上找到了David Zemens的代码，但是我不知道如何将该代码或该代码的版本合并到我现有的代码中，以产生另外3列。我需要使用.jpg，.cr2和.nef文件格式的代码。

我是VBA的新手。

谢谢。

Option Explicit

Sub GetMetaDataFromPictureFiles()

    Dim objShellApp As Object
    Dim objFolder As Object
    Dim varColumns As Variant
    Dim arrData() As Variant
    Dim wksResults As Worksheet
    Dim strPath As String
    Dim strFilename As String
    Dim fileCount As Long
    Dim i As Long
    Dim j As Long

    strPath = ThisWorkbook.Worksheets("Directions").Range("a2").Value

    Set objShellApp = CreateObject("Shell.Application")

    On Error Resume Next
    Set objFolder = objShellApp.Namespace(CStr(strPath))
    If objFolder Is Nothing Then
        MsgBox "Folder not found!", vbExclamation, "Folder?"
        Set objShellApp = Nothing
        Exit Sub
    End If
    On Error GoTo 0

    varColumns = Array(0, 1, 2, 12, 30)

    ReDim arrData(0 To UBound(varColumns), 0 To objFolder.items.Count)

    For i = LBound(arrData, 1) To UBound(arrData, 1)
        arrData(i, 0) = objFolder.getdetailsof(objFolder.items, varColumns(i))
    Next i

    fileCount = 0
    For i = 0 To objFolder.items.Count - 1
        strFilename = objFolder.getdetailsof(objFolder.items.Item(CLng(i)), 0)
        If Right(strFilename, 4) = ".jpg" Or Right(strFilename, 4) = ".JPG" Or Right(strFilename, 4) = ".CR2" Or Right(strFilename, 4) = ".cr2" Or Right(strFilename, 4) = ".nef" Or Right(strFilename, 4) = ".NEF" Then
            fileCount = fileCount + 1
            For j = 0 To UBound(varColumns)
                arrData(j, fileCount) = objFolder.getdetailsof(objFolder.items.Item(CLng(i)), varColumns(j))
            Next j
        End If
    Next i

    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Worksheets(objFolder.Title).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set wksResults = ThisWorkbook.Worksheets.Add
    wksResults.Name = objFolder.Title

    With wksResults
        .Range("A1").Resize(UBound(arrData, 2) + 1, UBound(arrData, 1) + 1).Value = Application.Transpose(arrData)
        .Columns.AutoFit

    Set objShellApp = Nothing
    Set objFolder = Nothing
    Set wksResults = Nothing

    End With

End Sub


Sub OpenFromFolder()

    OnErrorGoTo ExifError

    Dim strDump AsString
    '## REQUIRES REFERENCE TO MICROSOFT SCRIPTING RUNTIME 
    Dim fso As Scripting.FileSystemObject
    Dim fldr As Scripting.Folder
    Dim file As Scripting.file

    Set fso = CreateObject("scripting.filesystemobject")
    Set fldr = fso.GetFolder("C:/users/david_zemens/desktop/")'#### Modify 
    this to your folder location

    ForEach file In fldr.Files
    '## ONLY USE JPG EXTENSION FILES!!
    SelectCase UCase(Right(file.Name,3))
    Case"JPG"
    WithGPSExifReader.OpenFile(file.Path)

    strDump = strDump &"FilePath: "&.FilePath & vbCrLf
    strDump = strDump &"DateTimeOriginal: "&.DateTimeOriginal & vbCrLf
    strDump = strDump &"GPSVersionID: "&.GPSVersionID & vbCrLf
    strDump = strDump &"GPSLatitudeDecimal: "&.GPSLatitudeDecimal & vbCrLf
    strDump = strDump &"GPSLongitudeDecimal: "&.GPSLongitudeDecimal & vbCrLf
    strDump = strDump &"GPSAltitudeDecimal: "&.GPSAltitudeDecimal & vbCrLf
    strDump = strDump &"GPSSatellites: "&.GPSSatellites & vbCrLf
    strDump = strDump &"GPSStatus: "&.GPSStatus & vbCrLf
    strDump = strDump &"GPSMeasureMode: "&.GPSMeasureMode & vbCrLf
    strDump = strDump &"GPSDOPDecimal: "&.GPSDOPDecimal & vbCrLf
    strDump = strDump &"GPSSpeedRef: "&.GPSSpeedRef & vbCrLf
    strDump = strDump &"GPSSpeedDecimal: "&.GPSSpeedDecimal & vbCrLf
    strDump = strDump &"GPSTrackRef: "&.GPSTrackRef & vbCrLf
    strDump = strDump &"GPSTrackDecimal: "&.GPSTrackDecimal & vbCrLf
    strDump = strDump &"GPSImgDirectionRef: "&.GPSImgDirectionRef & vbCrLf
    strDump = strDump &"GPSImgDirectionDecimal: "&.GPSImgDirectionDecimal & 
    vbCrLf
    strDump = strDump &"GPSMapDatum: "&.GPSMapDatum & vbCrLf
    strDump = strDump &"GPSDestLatitudeDecimal: "&.GPSDestLatitudeDecimal & 
    vbCrLf
    strDump = strDump &"GPSDestLongitudeDecimal: "&.GPSDestLongitudeDecimal & 
    vbCrLf
    strDump = strDump &"GPSDestBearingRef: "&.GPSDestBearingRef & vbCrLf
    strDump = strDump &"GPSDestBearingDecimal: "&.GPSDestBearingDecimal & 
    vbCrLf
    strDump = strDump &"GPSDestDistanceRef: "&.GPSDestDistanceRef & vbCrLf
    strDump = strDump &"GPSDestDistanceDecimal: "&.GPSDestDistanceDecimal & 
    vbCrLf
    strDump = strDump &"GPSProcessingMethod: "&.GPSProcessingMethod & vbCrLf
    strDump = strDump &"GPSAreaInformation: "&.GPSAreaInformation & vbCrLf
    strDump = strDump &"GPSDateStamp: "&.GPSDateStamp & vbCrLf
    strDump = strDump &"GPSTimeStamp: "&.GPSTimeStamp & vbCrLf
    strDump = strDump &"GPSDifferentialCorrection: 
    "&.GPSDifferentialCorrection 
    & vbCrLf

    Debug.Print strDump '## Modify this to print the results wherever you want them...

    EndWith
    EndSelect
    NextFile:
    Next
    ExitSub

    ExifError:
    MsgBox "An error has occurred with file: "& file.Name & vbCrLf & vbCrLf & 
    Err.Description
    Err.Clear
    Resume NextFile

EndSub