vba - Excel VBA打开文件夹并获取其中每个文件的GPS信息(Exif)

Question

在另一篇文章中的 Jzz 和 David 的指导下，我发现了一个可以导入到 Access DB 或 Excel 的 VBA 用户表单和模块，它会要求您选择一个文件，并且会显示该文件的 EXIF 外部信息，特别是 GPS 经度、纬度和海拔高度。

我的问题是如何转换它，以便它打开一个文件夹并检索该文件夹中每个文件的 GPS 信息。我知道它可能需要循环遍历文件夹的内容，但我不知道如何转换它。请参阅附件并将其作为 Access DB 打开。我只能将其传输到 Excel，但代码中编写了太多额外的调用和函数，我无法立即理解。如果能够对其进行修改并使其更短，那就太好了。

EXIFReader

莎拉

编辑感谢大卫，这是我的修改版本:

Sub OpenFromFolder()

On Error GoTo ExifError

    Dim strDump As String
    '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/JayP/Downloads/Camera Uploads/Pics")  '#### Modify this to your folder location

    For Each file In fldr.Files
    '## ONLY USE JPG EXTENSION FILES!!
    Select Case UCase(Right(file.Name, 3))
        Case "JPG"
            With GPSExifReader.OpenFile(file.Path)
                currrow = Sheet1.UsedRange.Rows.Count + 1
                Sheet1.Range("A" & currrow).Value = "GPSLatitudeDecimal:        " & .GPSLatitudeDecimal
                Sheet1.Range("B" & currrow).Value = "GPSLongitudeDecimal:       " & .GPSLongitudeDecimal
                Sheet1.Range("C" & currrow).Value = "GPSAltitudeDecimal:        " & .GPSAltitudeDecimal
           End With
       End Select
NextFile:
    Next
    Exit Sub

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

Answer 1

这是相当复杂的代码——由 Wayne Phillips 编写。他是经过认证的 Microsoft MVP。虽然让代码更易于阅读可能会很好，但我怀疑它已经相当优化了。

我发布这个答案是因为这是一个有趣的问题/应用程序，通常我会说“告诉我到目前为止你已经尝试过什么”，但考虑到韦恩代码的相对复杂性，我会放弃这个要求。然而，额外的警告是，我不会回答有关此代码的十几个后续问题来教您如何使用 VBA。 此代码经过测试并且可以工作。

有一个未使用的函数调用，允许您从路径打开，我们将在指定文件夹中的文件上循环使用它。

Function OpenFile(ByVal FilePath As String) As GPSExifProperties
    Set OpenFile = m_ClassFactory.OpenFile(FilePath)
End Function

1. 将类模块从 Wayne 的代码导入到您工作簿的 VBProject 中(我认为您已经完成了此操作)。

2. 在普通代码模块中创建一个如下所示的新子例程。

Sub OpenFromFolder()

On Error GoTo ExifError

    Dim strDump As String
    '## 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

    For Each file In fldr.Files
    '## ONLY USE JPG EXTENSION FILES!!
    Select Case UCase(Right(file.Name, 3))
        Case "JPG"
            With GPSExifReader.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...

           End With
       End Select
NextFile:
    Next
    Exit Sub

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

End Sub

您需要修改此:

Set fldr = fso.GetFolder("C:/users/david_zemens/desktop/") 

还有这个。我假设您已经知道如何将数据放入工作表或将其显示在表单等上。此行仅打印到 VBA 立即窗口中的控制台，它不会写入工作表/等。除非你修改它来这样做。这不是问题的一部分，所以我将把它留给你来解决:)

Debug.Print strDump 

注意:我删除了 Excel 中没有的一些对象变量，并添加了一些新变量来执行文件夹/文件迭代。我放入了简单的错误处理来通知您错误(msgbox)并恢复下一个文件。在我的测试中，我遇到的唯一错误是某些文件没有 EXIF 数据。