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

在另一篇文章的指导下，我发现了一个VBA的用户表单和模块，可以导入到Access数据库或Excel中，要求您select一个文件，它将显示该文件的EXIF外部信息，特别是GPS Longitude，Latitude，和高度。

我的问题是如何转换这个，所以它打开一个文件夹，并检索该文件夹中的每个文件的GPS信息。 我知道它可能需要遍历文件夹的内容，但我不知道如何转换这个。 请参阅附件，并将其作为Access DB打开。 我只能将它转移到Excel中，但是代码被写入太多额外的调用和function，我不能马上理解。 能够修改并缩短它会很好。

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

这是相当复杂的代码，由韦恩菲利普斯谁是一个authentication的微软MVP写。 尽pipe让代码更易读，但我怀疑它已经相当优化了。

我张贴这个答案，因为这是一个有趣的问题/应用程序，通常我会说：“告诉我你迄今为止所尝试的”，但考虑到韦恩的代码相对复杂，我会放弃这一要求。 但是额外的警告是，我不会回答这个代码的十几个后续问题， 教你如何使用VBA。 此代码已经过testing，可以正常工作。

有一个未使用的函数调用，允许您从一个path打开，我们打算在一个循环中使用这个指定文件夹中的文件。

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

1.从Wayne的代码中导入类模块到你的工作簿的VBProject（我想你已经这样做了）。

2.在正常的代码模块中创build一个如下所示的新子程序。

 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的立即窗口中的控制台，它不会写入工作表/ etc。 除非你修改它。 这不是问题的一部分，所以我会留给你解决:)

 Debug.Print strDump 

注意：我删除了一些在Excel中没有的对象variables，并添加了一些新variables来执行文件夹/文件迭代。 我把简单的error handling通知你的错误（msgbox），并恢复下一个文件。 在我的testing中，唯一的错误是一些文件没有EXIF数据。