Excel VBA 打开文件夹并获取其中每个文件的 GPS 信息（Exif）
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/24028576/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA open folder and get GPS info (Exif) of each files in it
提问by user3682866
Guided by Jzz and David on another post, I discovered a VBA userform and modules that can be imported to Access DB or Excel that will ask you to select a file and it will display the EXIF external info of that file particularly GPS Longitude, Latitude, and Altitude.
在 Jzz 和 David 的另一篇文章的指导下，我发现了一个 VBA 用户表单和模块，它们可以导入到 Access DB 或 Excel 中，它会要求您选择一个文件，它会显示该文件的 EXIF 外部信息，特别是 GPS 经度、纬度、和海拔。
My question is how do I convert this so it opens a folder instead and retrieves the GPS info on each of the files in that folder. I know it may need to loop through the contents of a folder but I have no idea how to convert this. Please see attached file and open it as Access DB. I was only able to transfer it to Excel but the code was written in too many extra calls and functions I couldn't understand right away. It would be nice to be able to modify it and make it shorter.
我的问题是如何转换它，以便它打开一个文件夹并检索该文件夹中每个文件的 GPS 信息。我知道它可能需要遍历文件夹的内容，但我不知道如何转换它。请参阅附件并将其作为 Access DB 打开。我只能将它传输到 Excel，但是代码是用太多我无法立即理解的额外调用和函数编写的。能够修改它并使其更短会很好。
Sarah
莎拉
EDIT Thanks to David, here's my modified version:
编辑感谢大卫，这是我的修改版本：
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
采纳答案by David Zemens
That is fairly sophisticated code -- written by Wayne Phillipswho is a certified Microsoft MVP. While it might be nice to make the code more human-readable, I suspect it is already quite optimized.
这是相当复杂的代码——由认证的 Microsoft MVP Wayne Phillips编写。虽然使代码更具可读性可能很好，但我怀疑它已经相当优化了。
I am posting this answer because it's an interesting question/application, normally I would say "Show me what you have tried so far" but given the relative complexity of Wayne's code, I'll waive that requirement. HOWEVER the additional caveat is that I won't answer a dozen follow-up questions on this code to teachyou how to use VBA. This code is tested and it works.
我发布这个答案是因为这是一个有趣的问题/应用程序，通常我会说“告诉我你到目前为止尝试过什么”但考虑到韦恩代码的相对复杂性，我会放弃这个要求。然而，额外的警告是，我不会回答有关此代码的十几个后续问题来教您如何使用 VBA。 这段代码已经过测试并且可以正常工作。
There is an unused function call that allows you to open from a path, we are going to use this in a loop, over the files in a specified folder.
有一个未使用的函数调用允许您从路径打开，我们将在循环中使用它，在指定文件夹中的文件上。
Function OpenFile(ByVal FilePath As String) As GPSExifProperties
Set OpenFile = m_ClassFactory.OpenFile(FilePath)
End Function
1.Import the Class Modules from Wayne's code in to your workbook's VBProject (I think you have already done this).
1.将 Wayne 代码中的类模块导入到您工作簿的 VBProject 中（我认为您已经这样做了）。
2.Create a new subroutine like the one below, in a normal code module.
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
You need to modify this:
你需要修改这个：
Set fldr = fso.GetFolder("C:/users/david_zemens/desktop/")
And also this. I assume you already know how to put the data in a worksheet or display it on a form, etc. This line only prints to the console in the Immediate window of the VBA, it will not write to a worksheet/etc. unless you modify it to do so. That is not part of the question, so I will leave that up to you to work out :)
还有这个。我假设您已经知道如何将数据放入工作表或将其显示在表单等上。此行仅打印到 VBA 的立即窗口中的控制台，它不会写入工作表/等。除非你修改它来这样做。这不是问题的一部分，所以我将把它留给你来解决:)
Debug.Print strDump
NOTE:I removed some object variables that you won't have in Excel, and added some new variables to do the Folder/Files iteration. I put in simple error handling to inform you of errors (msgbox) and resume the next file. In my testing, the only error I got was some files do not have EXIF data.
注意：我删除了一些您在 Excel 中没有的对象变量，并添加了一些新变量来执行文件夹/文件迭代。我进行了简单的错误处理以通知您错误（msgbox）并恢复下一个文件。在我的测试中，我得到的唯一错误是某些文件没有 EXIF 数据。
