Excel VBA открыть папку и получить информацию GPS (Exif) каждого файла в нем (2)

Question

Я пытаюсь получить метаданные Exif из файлов jpg (данные о широте и долготе GPS, встроенные в изображения, снятые камерой Nikon Coolpix W300), используя код модулей класса Уэйна Филлипса (приложение доступа EXIFReader) и подпрограмму David Zemens.предложено в посте «Открыть папку Excel VBA и получить информацию GPS (Exif) для каждого файла в ней» (ссылка на исходное сообщение: Как получить информацию EXIF ​​из изображения на листе Excel с использованием VBA ).

Руководствуясь Дэвидом Ансваром, я перепробовал все, что он предложил:

1) Я импортировал Модули классов из кода Уэйна в свой проект рабочей книги;

2) В модулях классов я изменил объявленные функции, сделав их совместимыми с 64-разрядными версиями Excel, используя объявление «PtrSafe»;

3) Я создал подпрограмму в точности, как предложил Дэвид, для обычного модуля кода;

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

Код Дэвида Земенса, который я пытаюсь использовать, приведен ниже:

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

Отладка, когда код запускается для запуска 4-й строки в блок With / End With, с ".GPSLatitudeDecimalmsgstr "инструкция, приложение вылетает.Он не приходит с сообщением об ошибке перед закрытием приложения Excel.Я хотел бы понять, что происходит с этим кодом, и как я могу это исправить и получить метаданные GPS, необходимые для создания моих ежемесячных фотоотчетов.

Answer 1

Попробуйте получить координаты GPS из данных EXIF, используя WIA.ImageFile, вот пример:

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

Answer 2

Нет ничего плохого в коде, который вы разместили. Я успешно запустил его, используя образцы изображений из GitHub . Я предполагаю, что вы неправильно вставили ptrSafe для преобразования в 64-битную версию. Образец с сайта Уэйна уже содержит все 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 без каких-либо изменений.