Excel VBA打开文件夹并获取其中的每个文件的GPS信息（Exif） [英] Excel VBA open folder and get GPS info (Exif) of each files in it
问题描述
在Jzz和David引导的另一篇文章中，我发现了一个VBA用户形式和模块，可以导入Access DB或Excel，这将要求您选择一个文件，它将显示该文件的EXIF外部信息，特别是GPS经度，纬度和海拔。
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.
我的问题是如何转换，以便它打开一个文件夹，并检索该文件夹中每个文件的GPS信息。我知道它可能需要循环访问一个文件夹的内容，但我不知道如何转换这个。请参阅附件，并将其打开为Access DB。我只能将其传输到Excel，但代码写入太多额外的电话和功能，我不能立即理解。这将是很好的能够修改它，使它更短。
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.
莎拉
编辑感谢David，这是我的修改版本：
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
推荐答案
这是相当复杂的代码 - 由 Wayne Phillips
That is fairly sophisticated code -- written by Wayne Phillips who is a certified Microsoft MVP. While it might be nice to make the code more human-readable, I suspect it is already quite optimized.
我发布这个答案是因为这是一个有趣的问题/应用程序，通常我会说告诉我你到目前为止已经尝试了什么，但是考虑到韦恩的代码相对复杂，我将放弃这一要求。不过，另外要注意的是，我不会回答关于这个代码的十几个后续问题，以便教你如何使用VBA。
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 teach you how to use VBA. This code is tested and it works.
有一个未使用的函数调用，允许您从一个路径打开，我们将使用这个在一个循环中，超过了指定文件夹中的文件。
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。 将Wayne的代码中的类模块导入到工作簿的VBProject（我想你已经完成了这个）。
1. Import the Class Modules from Wayne's code in to your workbook's VBProject (I think you have already done this).
2。在正常的代码模块中创建一个新的子程序，如下所示。
2. Create a new subroutine like the one below, in a normal code module.
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。除非你修改它这样做。这不是问题的一部分，所以我会留下你的工作：）
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 :)
Debug.Print strDump
注意：我删除了一些您不会在Excel中的对象变量，并添加了一些新的变量来进行文件夹/文件的迭代。我简单的错误处理通知你错误（msgbox）并恢复下一个文件。在我的测试中，唯一的错误是一些文件没有EXIF数据。
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 VBA打开文件夹并获取其中的每个文件的GPS信息（Exif）的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
