logo标签列表

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

excelvba
6
我正在尝试使用Wayne Phillips的类模块代码（EXIFReader访问应用程序）和David Zemens在“Excel VBA打开文件夹并获取其中每个文件的GPS信息（Exif）”帖子中提出的子例程建议，从jpg文件中检索Exif元数据（嵌入在使用Nikon Coolpix W300相机拍摄的图片中的GPS纬度和经度数据）（原始帖子链接：如何使用VBA在Excel工作表中获取图片的EXIF信息）。
在David的回答指导下，我尝试了他提出的所有方法：
1）我将Wayne的类模块导入到我的工作簿项目中；
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

Wayne的类模块代码可以在此链接中找到：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

调试代码时，当代码运行到第四行进入With/End With块，并执行“.GPSLatitudeDecimal”指令时，应用程序崩溃。 在关闭Excel应用程序之前没有出现错误消息。 我想了解这段代码出了什么问题，如何修复它并检索我需要制作月度照片报告的GPS元数据。
3
除了导致问题的jpg文件，我们已经拥有所有所需的内容。能否上传/附上该文件？ - donPablo
1
该类依赖于最低级别的代码注入。它没有文档，也没有源代码，因此创建者很可能是唯一能够修复它的人。 - Florent B.
1
EXIF已经被很好地规范和文档化。您可以直接使用VBA读取EXIF属性。也可以通过Windows API实现：gdiplus-reading-and-writing-metadata-use。 - Florent B.
2个回答
9
尝试使用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
1
WIA.ImageFile 是个不错的发现。 - S Meaden
4
如果有人喜欢使用早期绑定：这是基于“Microsoft Windows Image Acquisition Library”，通过引用它，您可以将其声明为 WIA.ImageFile 对象。 - Asger
3

你发布的代码没有问题。我使用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文件，导出了三个类模块，然后将它们不做任何修改地重新导入到Excel文件中。
网页内容由stack overflow 提供, 点击上面的
可以查看英文原文，
原文链接