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

Question

我正在尝试从jpg文件(GPS纬度和经度数据，嵌入使用尼康Coolpix W300相机拍摄的照片中)中检索Exif元数据，使用Wayne Phillips类模块代码(EXIFReader访问应用程序)和David Zemens子例程建议"Excel VBA打开文件夹并获取其中每个文件的GPS信息(Exif)"帖子(原始帖子的链接： 如何使用VBA从Excel工作表中的图片中获取EXIF信息)。

在David answare的指导下，我尝试了他提出的所有建议：

1)我将韦恩代码中的类模块导入到我的工作簿项目中;

2)在类模块中，我修改了声明的函数，使其与Excel 64位兼容，使用"PtrSafe"声明;

3)我在一个普通的代码模块上创建了一个完全像David提议的子例程;

4)我已将文件夹路径更新为正确的文件夹路径

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

5)我已经编译并调试了项目，当代码运行以下指令时，我遇到了应用程序崩溃，存储在GPSExif属性类模块中：

Property Get GPSLatitudeDecimal() As Variant Call **VCOMObject**.AssignVar(GPSLatitudeDecimal, VCOMObject.GPSLatitudeDecimal) End Property

Wayne 的类模块代码可以在此链接中找到：https://www.everythingaccess.com/tutorials.asp?ID=Extracting-GPS-data-from-JPEG-files

我尝试使用的David Zemens Code如下：

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("E:DNITRelatório FotográficoFotos com dados GPS")  '#### 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

调试它，当代码启动时，将第 4 行运行到 With/End With 块中，带有".GPSLatitudeDecimal"指令，应用程序崩溃。 在关闭 excel 应用程序之前，它不会附带错误消息。 我想了解此代码出了什么问题，以及如何修复它并检索制作每月照片报告所需的 GPS 元数据。

Answer 1

尝试使用 WIA 从 EXIF 数据中获取 GPS 坐标。图像文件，下面是示例：

Sub Test()
With CreateObject("WIA.ImageFile")
.LoadFile "C:Testimage.jpg"
With .Properties("GpsLatitude").Value
Debug.Print .Item(1).Value + .Item(2).Value / 60 + .Item(3).Value / 3600
End With
With .Properties("GpsLongitude").Value
Debug.Print .Item(1).Value + .Item(2).Value / 60 + .Item(3).Value / 3600
End With
End With
End Sub

Answer 2

您发布的代码没有任何问题。我使用GitHub上的示例图像成功运行了它。 我的猜测是您没有正确插入 ptrSafe 以转换为 64 位。Wayne 站点中的示例已经包含所有 64 位声明。

#If VBA7 = False Then
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal Address As Long, ByVal Size As Long, ByVal AllocationType As Long, ByVal Protect As Long) As Long
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal ProcName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal Module As Long, ByVal ProcName As String) As Long
Private Declare Sub CopyMemoryAnsi Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As Long, ByVal Source As String, ByVal Size As Long)
Private Declare Sub CastToObject Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Object, ByRef Source As Long, ByVal Size As Long)
Private Type IDispatchVTable
QueryInterface As Long
AddRef As Long
Release As Long
GetTypeInfoCount As Long
GetTypeInfo As Long
GetIDsOfNames As Long
Invoke As Long
End Type
#Else
Private Declare PtrSafe Function VirtualAlloc Lib "kernel32" (ByVal Address As LongPtr, ByVal Size As LongPtr, ByVal AllocationType As Long, ByVal Protect As Long) As LongPtr
Private Declare PtrSafe Function GetModuleHandleA Lib "kernel32" (ByVal ProcName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal Module As LongPtr, ByVal ProcName As String) As LongPtr
Private Declare PtrSafe Sub CopyMemoryAnsi Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As LongPtr, ByVal Source As String, ByVal Size As LongPtr)
Private Declare PtrSafe Sub CastToObject Lib "kernel32" Alias "RtlMoveMemory" (ByRef Dest As Object, ByRef Source As LongPtr, ByVal Size As LongPtr)
Private Type IDispatchVTable
QueryInterface As LongPtr
AddRef As LongPtr
Release As LongPtr
GetTypeInfoCount As LongPtr
GetTypeInfo As LongPtr
GetIDsOfNames As LongPtr
Invoke As LongPtr
End Type
#End If

我打开了 mdb 文件，导出了 3 个类模块，然后将它们重新导入到 Excel 文件中，没有任何修改。