VBA to get name, date and GPS data from pictures in a folder

L

lex_m

Board Regular
Joined
Aug 5, 2003
Messages
155
I have looked and can't fine code to do this, I have a folder with pictures in it and I would like to put the names of each picture in the folder in column A, date taken in column B and if the pictures have GPS data for them put the latitude in column C and the longitude in column D, can this be done in Excel version 2003?
Thanks
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Hi Lex,
that's actually a question that has been in the back of my mind for a while. I gave it a swing and this seems to work for me to extract the Lat&Long, but I'm using Win10+Office365.
Hope it works for you too,
Koen

Code: 
Sub GetFileInfo()

    'Reference: Microsoft Shell Controls and Automation  - C:\Windows\SysWOW64\shell32.dll
    
    Dim objShell As New Shell
    Set FS = CreateObject("Scripting.FileSystemObject")
    strFolder = "C:\Pictures\desktopbackground\"
    strTemp = "20170212_135a.jpg"
    Rw = 2
    
    Set Fl = FS.GetFile(strFolder & strTemp)
    Worksheets("Src").Cells(Rw, 2).Value = strFolder
    Worksheets("Src").Cells(Rw, 3).Value = strTemp
    Worksheets("Src").Cells(Rw, 4).Value = Fl.DateLastModified
    Debug.Print Fl.Type
    If Fl.Type = "JPEG image" Or Fl.Type = "PNG image" Or Fl.Type = "GIF image" Or Fl.Type = "JPG-bestand" Then
        'Images only
        Set objFolder = objShell.Namespace(strFolder)
        Set objFile = objFolder.ParseName(strTemp)
        iPictureSize = objFile.ExtendedProperty("Dimensions")
        iLat = objFile.ExtendedProperty("{8727CFFF-4868-4EC6-AD5B-81B98521D1AB}100")
        iLng = objFile.ExtendedProperty("{C4C4DBB2-B593-466B-BBDA-D03D27D5E43A}100")
        If Not IsEmpty(iLat) Then
            LatDec = iLat(0) + iLat(1) / 60 + iLat(2) / 3600
        Else
            LatDec = 0
        End If
        If Not IsEmpty(iLng) Then
            LngDec = iLng(0) + iLng(1) / 60 + iLng(2) / 3600
        Else
            LngDec = 0
        End If
        Worksheets("Src").Cells(Rw, 5).Value = Val(Mid(iPictureSize, 2, InStr(iPictureSize, "x") - 2))
        Worksheets("Src").Cells(Rw, 6).Value = Val(Mid(iPictureSize, InStr(iPictureSize, "x") + 1))
        Worksheets("Src").Cells(Rw, 7).Value = LatDec
        Worksheets("Src").Cells(Rw, 8).Value = LngDec
        Set objFile = Nothing
        Set objFolder = Nothing
    End If

End Sub
 
Upvote 0
Koen, thanks for taking the time to look at this.
I have set a Reference: Microsoft Shell Controls and Automation, I am not sure what the C:\Windows\SysWOW64\shell32.dll is, is that the location of the shell control on your computer?
When I run the code I am only getting the file location name and date modified in columns B, C, and D. I know the file has GPS data in it.

Any thoughts on this or how I might trouble shoot it, I know a little about VBA but not a lot
 
Upvote 0
Hi Lex,
the reference can normally be found by name, but I added the file path (in my system) as it sometimes misses from the list where you can select them.

A second attempt, using a different technique I found online:

Code: 
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
Hope that works,
Koen
 
Upvote 0
Koen, thanks that does put the GPS data in the sheet! If I could ask one more thing, how would I make this look at the folder and list all the pictures that are in the folder with there data in the sheet starting in row 2 down, so if there was 10 pictures it would list them in rows 2:11
Thanks again
 
Upvote 0
Upvote 0
Here is my attempt, will load the data for the pictures in gpstest folder bur if the picture does NOT have GPS data it shows the data for the picture that was before it, with the original code when I picked a picture without GPS data it would show a 0 for Lat and Long. Any thoughts?
Thanks

Code: 
Sub GetGPSData()

    Dim fileName As Variant
    fileName = Dir(Application.DefaultFilePath _
                 & "\My Pictures\gpstest\")

    While fileName <> ""


        'Insert the actions to be performed on each file

        strFolder = Application.DefaultFilePath _
                  & "\My Pictures\gpstest\"


        'Reference to Microsoft Windows Image Acquisition Library 2.0
        Set ImgFile = New WIA.ImageFile
        ImgFile.LoadFile (strFolder & fileName)

        Rw = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
        For Each P In ImgFile.Properties
            Debug.Print P.Name
        Next P

        Worksheets("Src").Cells(Rw, 1).Value = strFolder
        Worksheets("Src").Cells(Rw, 2).Value = fileName

        On Error Resume Next    ' some of the pictures do not have this data
        Worksheets("Src").Cells(Rw, 3).Value = ImgFile.Properties("DateTime")
        On Error GoTo 0

        If UCase(Right(fileName, 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, 4).Value = LatDec
            Worksheets("Src").Cells(Rw, 5).Value = LngDec
        End If


        'Set the fileName to the next file
        fileName = Dir
    Wend

End Sub
 
Upvote 0
Hi Lex,
almost there! After the line Worksheets("Src").Cells(Rw, 5).Value = LngDec -> add 2 lines:
iLng = Empty
iLat = Empty
That should clear the variables so it should show 0 for the next file. You can remove/outcomment the "For Each P" loop (3 lines), as it doesn't add anything to the process, it just slows it down a bit.
Cheers,
Koen
 
Upvote 0
Koen, that fix it! When I ran it on my folder with more pictures I was getting and error sometime, some of the pictures did not have date\time information so I put a On Error Resume Next at the start and On Error GoTo 0 at the end and it looks like it is working fine.
Thanks again for you help on this.
 
Upvote 0
H
Rijnsent said:
Hi Lex,
the reference can normally be found by name, but I added the file path (in my system) as it sometimes misses from the list where you can select them.

A second attempt, using a different technique I found online:

Code: 
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
Hope that works,
Koen
Click to expand...
Hi Lex,
you can format column datetime="yyyy-mm-dd hh:mm:ss" ?
thanks!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

KlausW
  • Solved
Excel VBA Error - Unable to get the Insert property of the Picture Class
Replies
7
Views
433
KlausW
KlausW
KlausW
  • Locked
  • Question Question
VBA code to move picture from on sheets to another sheet
Replies
1
Views
61
Fluff
Fluff
S
  • Solved
Place in cell
Replies
4
Views
210
Silverwolph
S
KlausW
  • Solved
VBA code to move picture from on sheets to another sheet
Replies
1
Views
57
KlausW
KlausW
H
  • Question Question
Macro to List Folders excluding Data Stamp within E:\Cobian
Replies
0
Views
73
howard
H

Forum statistics

Threads
1,224,815
Messages
6,181,135
Members
453,021
Latest member
Justyna P

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top