GPS gegevens uit foto halen

[AatB]

Hallo, ik wil foto's afdrukken met op de achterkant een landkaartje waar deze foto genomen en wanneer.
Als ik bij eigenschappen van de foto kijk, zie ik de GPS gegevens staan (Lengtegraad, Breedtegraad en Hoogte).

Middels een macro wil de foto kiezen en de foto + gps gegevens in een excelsheet zetten.
Daarna kan ik dan via Google maps het kaartje ophalen mbv de gps gegevens.

Met deze code haal ik alle gegevens op, maar de GPS gegevens staan er niet bij.

Sub CheckAlleEigenschappen()
    Dim shellApp As Object, folderObj As Object, fileObj As Object
    Dim filePath As String, fileName As String, folderPath As String
    Dim i As Integer
    
    With Application.FileDialog(msoFileDialogFilePicker)
        If .Show = -1 Then filePath = .SelectedItems(1) Else Exit Sub
    End With
    
    folderPath = Left(filePath, InStrRev(filePath, "\") - 1)
    fileName = Mid(filePath, InStrRev(filePath, "\") + 1)
    Set shellApp = CreateObject("Shell.Application")
    Set folderObj = shellApp.Namespace(CVar(folderPath))
    Set fileObj = folderObj.ParseName(fileName)
    
    
    ActiveSheet.Cells.ClearContents
    For i = 0 To 370
        Cells(i + 1, 1).Value = i
        Cells(i + 1, 2).Value = folderObj.GetDetailsof(Null, i) ' De naam van het veld
        Cells(i + 1, 3).Value = folderObj.GetDetailsof(fileObj, i) ' De waarde
    Next i
    Columns("A:C").AutoFit
End Sub

Weet iemand een oplossing?

Bedankt alvast.

mvg,

Aat

 

[Tech8]

Ik gebruik hiervoor Opanda.

Exif viewer : Opanda IExif - Professional EXIF / GPS / IPTC Viewer & Editor in Windows, IE & Firefox

 

[OctaFish]

Wat de vorige post met Excel en VBA te maken heeft, zie ik even niet. Exit informatie kun je met veel,programma's zien, zoals FastViewer. Heb je deze macro al bekeken?

Sub GetFileInfo2()
    strFolder = "C:Pictures\desktopbackground\"

    strFile = "20170312_101b.jpg"
    'Reference to Microsoft Windows Image Acquisition Library 2.0
    Set ImgFile = New WIA.ImageFile
    ImgFile.LoadFile (strFolder & strFile)
    Rw = 3
    For Each P In ImgFile.Properties
        Debug.Print P.Name
    Next P
    Worksheets("Src").Cells(Rw, 2).Value = strFolder
    Worksheets("Src").Cells(Rw, 3).Value = strFile
    Worksheets("Src").Cells(Rw, 4).Value = ImgFile.Properties("DateTime")
    If UCase(Right(strFile, 3)) = "JPG" Then
        'Images only
        On Error Resume Next
        iLat = ImgFile.Properties("GpsLatitude")
        iLatRef = ImgFile.Properties("GpsLatitudeRef")
        iLng = ImgFile.Properties("GpsLongitude")
        iLngRef = ImgFile.Properties("GpsLongitudeRef")
        On Error GoTo 0
        If Not IsEmpty(iLat) Then
            LatDec = iLat(1) + iLat(2) / 60 + iLat(3) / 3600
            If iLatRef = "S" Then LatDec = LatDec * -1
        Else
            LatDec = 0
        End If
        If Not IsEmpty(iLng) Then
            LngDec = iLng(1) + iLng(2) / 60 + iLng(3) / 3600
            If iLngRef = "W" Then LngDec = LngDec * -1
        Else
            LngDec = 0
        End If
        Worksheets("Src").Cells(Rw, 5).Value = ImgFile.Width
        Worksheets("Src").Cells(Rw, 6).Value = ImgFile.Height
        Worksheets("Src").Cells(Rw, 7).Value = LatDec
        Worksheets("Src").Cells(Rw, 8).Value = LngDec
    End If

End Sub

 

[Warme bakkertje]

Octa, zit een foutje in je strFolder pad.

 

[OctaFish]

't is mijn code dan ook niet

 

[mvdvlist]

Api key static Maps aanmaken via Google Cloud console (gratis tot 1000 fotos) en deze codes runnen. Even aanpassen uiteraard

Sub FotoNaarKaart()
    Dim shp As Shape
    Dim imgPath As String
    Dim lat As Double, lon As Double
    Dim mapFile As String
    Dim apiKey As String

    apiKey = "JOUW_GOOGLE_MAPS_API_KEY"

    If TypeName(Selection) <> "Picture" And TypeName(Selection) <> "ShapeRange" Then
        MsgBox "Selecteer eerst een foto."
        Exit Sub
    End If

    Set shp = Selection.ShapeRange(1)
    imgPath = shp.LinkFormat.SourceFullName

    If Not GetGPSFromImage(imgPath, lat, lon) Then
        MsgBox "Geen GPS EXIF gevonden in deze foto."
        Exit Sub
    End If

    mapFile = Environ("TEMP") & "\kaartje.png"

    If Not DownloadMap(lat, lon, mapFile, apiKey) Then
        MsgBox "Kon kaart niet downloaden."
        Exit Sub
    End If

    Dim m As Shape
    Set m = ActiveSheet.Pictures.Insert(mapFile)

    m.Left = shp.Left
    m.Top = shp.Top + shp.Height + 10

    MsgBox "Kaartje toegevoegd."
End Sub

Succes

 

[snb]

Iz voldoende:

Sub M_snb()
  With New WIA.ImageFile
    .LoadFile "D:\afbeeldingen\voorbeeld.jpg"
     it = .Properties(39)
     MsgBox "N " & it(1) & " " & it(2) & " " & it(3)
     it = .Properties(41)
     MsgBox "E " & it(1) & " " & it(2) & " " & it(3)
  End With
End Sub

 

[mvdvlist]

Prachtig. Om daarop voort te borduren: deze code hier alles uit, laat je zelfs eerst een foto kiezen..

Option Explicit

'===============================
'  FOTO → EXIF → GPS → MAP
'===============================

Sub FotoNaarKaart()

    Dim imgPath As String
    Dim lat As Double, lon As Double
    Dim shp As Shape
    Dim mapFile As String
    Dim apiKey As String

    apiKey = "JOUW_GOOGLE_MAPS_API_KEY"   ' <-- Vul hier jouw API key in

    '-----------------------------
    ' 1. Foto kiezen
    '-----------------------------
    imgPath = KiesFoto()

    If imgPath = "" Then
        MsgBox "Geen foto gekozen.", vbExclamation
        Exit Sub
    End If

    '-----------------------------
    ' 2. Foto invoegen
    '-----------------------------
    On Error Resume Next
    Set shp = ActiveSheet.Pictures.Insert(imgPath)
    On Error GoTo 0

    If shp Is Nothing Then
        MsgBox "Kon foto niet invoegen.", vbCritical
        Exit Sub
    End If

    shp.LockAspectRatio = msoTrue
    shp.Left = 20
    shp.Top = 20

    '-----------------------------
    ' 3. EXIF uitlezen
    '-----------------------------
    If Not GetGPSfromPhoto(imgPath, lat, lon) Then
        MsgBox "Geen GPS EXIF gevonden in deze foto.", vbExclamation
        Exit Sub
    End If

    '-----------------------------
    ' 4. Kaart downloaden
    '-----------------------------
    mapFile = Environ("TEMP") & "\kaartje.png"

    If Not DownloadMap(lat, lon, mapFile, apiKey) Then
        MsgBox "Kon kaart niet downloaden.", vbCritical
        Exit Sub
    End If

    '-----------------------------
    ' 5. Kaart invoegen onder foto
    '-----------------------------
    Dim m As Shape
    Set m = ActiveSheet.Pictures.Insert(mapFile)

    m.LockAspectRatio = msoTrue
    m.Left = shp.Left
    m.Top = shp.Top + shp.Height + 10

    MsgBox "Kaartje toegevoegd.", vbInformation

End Sub



'===============================
'  FOTO KIEZEN
'===============================
Function KiesFoto() As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd
        .Title = "Kies een foto"
        .Filters.Clear
        .Filters.Add "Afbeeldingen", "*.jpg;*.jpeg;*.png"
        .AllowMultiSelect = False

        If .Show = -1 Then
            KiesFoto = .SelectedItems(1)
        Else
            KiesFoto = ""
        End If
    End With
End Function



'===============================
'  EXIF → GPS uitlezen via WIA
'===============================
Function GetGPSfromPhoto(imgPath As String, ByRef lat As Double, ByRef lon As Double) As Boolean
    On Error GoTo fout

    Dim img As New WIA.ImageFile
    Dim it

    img.LoadFile imgPath

    ' Latitude
    it = img.Properties(39).Value
    lat = GPStoDecimal(it)

    ' Longitude
    it = img.Properties(41).Value
    lon = GPStoDecimal(it)

    GetGPSfromPhoto = True
    Exit Function

fout:
    GetGPSfromPhoto = False
End Function



'===============================
'  GPS → DECIMALE GRADEN
'===============================
Function GPStoDecimal(it) As Double
    GPStoDecimal = it(1) + it(2) / 60 + it(3) / 3600
End Function



'===============================
'  GOOGLE MAPS DOWNLOADEN
'===============================
Function DownloadMap(lat As Double, lon As Double, savePath As String, apiKey As String) As Boolean
    On Error GoTo fout

    Dim http As Object, url As String, bytes() As Byte

    url = "https://maps.googleapis.com/maps/api/staticmap?center=" & _
          lat & "," & lon & "&zoom=15&size=600x400&markers=color:red|" & _
          lat & "," & lon & "&key=" & apiKey

    Set http = CreateObject("WinHTTP.WinHTTPRequest.5.1")
    http.Open "GET", url, False
    http.Send

    If http.Status <> 200 Then Exit Function

    bytes = http.ResponseBody

    With CreateObject("ADODB.Stream")
        .Type = 1
        .Open
        .Write bytes
        .SaveToFile savePath, 2
        .Close
    End With

    DownloadMap = True
    Exit Function

fout:
    DownloadMap = False
End Function