我正在尝试使用Wayne Phillips类模块代码（EXIFReader访问应用程序）和David Zemens子例程从jpg文件（GPS纬度和经度数据，嵌入在用Nikon Coolpix W300相机拍摄的照片中嵌入）中检索Exif元数据。 Excel VBA打开文件夹并获取其中的每个文件的GPS信息（Exif）（原始文章的链接：如何使用VBA从excel工作表中的图片中获取EXIF信息）。
在David answare的指导下，我尝试了他提出的所有建议：
1）我从韦恩代码中将类模块导入到我的工作簿项目中；
2）在类模块中，我使用“ PtrSafe”声明修改了声明的函数，使其与Excel 64位兼容；
3）我在普通代码模块上创建了一个完全像David提议的子例程；
4）我已将文件夹路径更新为正确的路径
（Set fldr=fso.GetFolder("C:/users/david_zemens/desktop/")）;
5）我已经编译和调试了项目，当代码运行下面的指令（存储在GPSExifProperties类模块中）时，我遇到了应用程序崩溃：
Property Get GPSLatitudeDecimal() As Variant Call **VCOMObject**.AssignVar(GPSLatitudeDecimal, VCOMObject.GPSLatitudeDecimal) End Property
韦恩的课程模块代码可在以下链接中找到：https : //www.everythingaccess.com/tutorials.asp?ID=Extracting-GPS-data-from-JPEG-files
我尝试使用的David Zemens代码如下：
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:\DNIT\Relatório Fotográfico\Fotos 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
调试它时，使用“ .GPSLatitudeDecimal”指令将代码的第4行运行到With / End With块中，应用程序崩溃。关闭excel应用程序之前，它没有错误消息。我想了解这段代码出了什么问题，以及如何解决该问题并检索制作每月照片报告所需的GPS元数据。
尝试使用WIA.ImageFile从EXIF数据获取GPS坐标，这是示例：
Sub Test()
With CreateObject("WIA.ImageFile")
.LoadFile "C:\Test\image.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
您发布的代码没有任何问题。我使用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 文件中，无需进行任何修改。