Excel VBA打开文件夹并获取其中每个文件的GPS信息（Exif）

Question

Excel VBA打开文件夹并获取其中每个文件的GPS信息（Exif）

3

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

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

EXIFReader

Sarah

编辑：感谢David，这是我的修改版本：

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

- user3682866

1个回答

网页内容由stack overflow 提供, 点击上面的

可以查看英文原文，
原文链接

- David Zemens · Accepted Answer

这是相当复杂的代码--由微软认证的MVPWayne Phillips编写。虽然将代码更加易于人类阅读可能很好，但我认为它已经非常优化了。

我发布这个答案是因为这是一个有趣的问题/应用，通常我会说“给我看看你到目前为止尝试了什么”，但考虑到Wayne的代码相对复杂，我会放弃这个要求。然而，额外的警告是我不会回答关于如何使用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数据。