Need help to change this code I found to get data information from a folder

D

dee101

Active Member
Joined
Aug 21, 2004
Messages
282
I found this macro to get some information from files in a folder, the folder I have has pictures in it and I want to get the date the picturs were taken, this is putting in some kind of date but it is not when they were taken.

How would I do that, I am using Excel 2003 if that helps

Thanks







Code: 
Sub listfiles()

Dim r As Integer, F As String, Directory As String

Directory = Application.DefaultFilePath _

& "\My Pictures\Old Building And Things\"

r = 1

Cells(r, 1) = "FileName"

Cells(r, 2) = "Size"

Cells(r, 3) = "Date Time"

Range("A1:c1").Font.Bold = True

'Get Directory

F = Dir(Directory) ', 7)

Do While F <> ""

r = r + 1

Cells(r, 1) = F

Cells(r, 2) = FileLen(Directory & F)

Cells(r, 3) = FileDateTime(Directory & F)

'Get next File

F = Dir()

Loop

End Sub
 

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
Sort by date Sort by votes
Try this:

VBA Code: 
Sub listfiles()

Dim r As Integer, F As String, Directory As String

Directory = "C:\Users\andrew.marshall\Desktop\"

r = 1

Cells(r, 1) = "FileName"

Cells(r, 2) = "Size"

Cells(r, 3) = "Date Time"

Cells(r, 3) = "Taken"

Range("A1:c1").Font.Bold = True

'Get Directory

F = Dir(Directory)

Do While F <> ""

r = r + 1

Cells(r, 1) = F

Cells(r, 2) = FileLen(Directory & F)

Cells(r, 3) = FileDateTime(Directory & F)

Cells(r, 4) = FindPicDate(Directory & F)



'Get next File

F = Dir()

Loop

End Sub

Public Function FindPicDate(PicFile As String) As String
      
    Dim bytes() As Byte
    Dim sLine() As String
    Dim fSize As Long, ExifDate As Long
    Dim i As Long, d As Long
    Dim ff      As Integer
    Dim Found   As Boolean
    
    ff = FreeFile
    fSize = FileLen(PicFile)
     
    If fSize > 1024 Then fSize = 1024 ' get 1st 1K of file.
    ReDim bytes(1 To fSize)

    Open PicFile For Binary As #ff
        Get #ff, 1, bytes
    Close ff
       
    sLine = Split(StrConv(bytes(), vbUnicode), Chr$(0))
    
    For i = 0 To UBound(sLine) ' does "Exif" exsist?
        ExifDate = InStr(1, sLine(i), "Exif")
        If ExifDate > 0 Then
            Found = True
            Exit For
        End If
    Next i
        
    If Found = False Then Exit Function ' return nothing, "Exif" not found!
    
    For d = i + 1 To UBound(sLine) ' find first ":" in file
        ExifDate = InStr(1, sLine(d), ":")
        If ExifDate > 0 Then
            FindPicDate = sLine(d) ' return date string
            Exit For
        End If
    Next d
            
End Function


Source:

Get date picture taken from image-VBForums

I want to know if its possible to get the date a picture was taken using vb6 and making it check a folder that has the pictures in and then creating a folder for the month it was taken and moving that picture into the folder created. So it would do this: Get all the pictures in the given...
www.vbforums.com
 
Upvote 0
Thanks for looking at this,

Ran the code and it looks like that is giving me the date the file was modified and not the date the picture was taken, the one I am looking at now is came back with the date as 4-22-2020 that is the date it was last modified but the date taken in properties/ details is 6-4-2018
 
Upvote 0
Strange, my test had the properties taken time. Could try adding in a print to see if it returns the date elsewhere:

VBA Code: 
Sub listfiles()

Dim r As Integer, F As String, Directory As String

Directory = "C:\Users\andrew.marshall\Desktop\"

r = 1

Cells(r, 1) = "FileName"

Cells(r, 2) = "Size"

Cells(r, 3) = "Date Time"

Cells(r, 3) = "Taken"

Range("A1:c1").Font.Bold = True

'Get Directory

F = Dir(Directory)

Do While F <> ""

r = r + 1

Cells(r, 1) = F

Cells(r, 2) = FileLen(Directory & F)

Cells(r, 3) = FileDateTime(Directory & F)

Cells(r, 4) = FindPicDate(Directory & F)



'Get next File

F = Dir()

Loop

End Sub

Public Function FindPicDate(PicFile As String) As String
      
    Dim bytes() As Byte
    Dim sLine() As String
    Dim fSize As Long, ExifDate As Long
    Dim i As Long, d As Long
    Dim ff      As Integer
    Dim Found   As Boolean
    
    ff = FreeFile
    fSize = FileLen(PicFile)
     
    If fSize > 1024 Then fSize = 1024 ' get 1st 1K of file.
    ReDim bytes(1 To fSize)

    Open PicFile For Binary As #ff
        Get #ff, 1, bytes
    Close ff
       
    sLine = Split(StrConv(bytes(), vbUnicode), Chr$(0))
    
    For i = 0 To UBound(sLine) ' does "Exif" exsist?
        ExifDate = InStr(1, sLine(i), "Exif")
        If ExifDate > 0 Then
            Found = True
            Exit For
        End If
    Next i
        
    If Found = False Then Exit Function ' return nothing, "Exif" not found!
    
    For d = i + 1 To UBound(sLine) ' find first ":" in file
        ExifDate = InStr(1, sLine(d), ":")
        If ExifDate > 0 Then
            FindPicDate = sLine(d) ' return date string
            Exit For
        End If
    Debug.Print sLine(d)
    Next d
            
End Function
 
Upvote 0
Only put 1 picture in the folder to test it came back with a date of 4-23-2020, that is the date it was modified, the date taken was 11-26-2017.



Not sure about how to use the Debug.Print but this is what the Immediate window shows if that helps



II*











[1]












[1]

‑





Ñ





[1]

‑





ï





















(





[1]





1[1]







2[1]







5



;[1]







I



[1]









i‡





à



%ˆ





\



œœ

€





P



žœ





Ð



$



DCIM\100MEDIA\DJI_0857.JPG

DJI





















































FC300C















































H









H









v01.14.4920
 
Upvote 0
Perfect reply, try this code instead though. Apologies:

VBA Code: 
Sub listfiles()

Dim r As Integer, F As String, Directory As String

Directory = "C:\Users\andrew.marshall\Desktop\"

r = 1

Cells(r, 1) = "FileName"

Cells(r, 2) = "Size"

Cells(r, 3) = "Date Time"

Range("A1:c1").Font.Bold = True

'Get Directory

F = Dir(Directory)

Do While F <> ""

r = r + 1

Cells(r, 1) = F

Cells(r, 2) = FileLen(Directory & F)

Cells(r, 3) = FileDateTime(Directory & F)

Cells(r, 4) = FindPicDate(Directory & F)



'Get next File

F = Dir()

Loop

End Sub


Private Function FindPicDate(PicFile As String) As String
      
    Dim bytes() As Byte
    Dim sLine() As String
    Dim fSize As Long, ExifDate As Long
    Dim i As Long, d As Long
    Dim ff      As Integer
    Dim Found   As Boolean
    
    ff = FreeFile
    fSize = FileLen(PicFile)
     
    If fSize > 1024 Then fSize = 1024 ' get 1st 1K of file.
    ReDim bytes(1 To fSize)

    Open PicFile For Binary As #ff
        Get #ff, 1, bytes
    Close ff
       
    sLine = Split(StrConv(bytes(), vbUnicode), Chr$(0))
    
    For i = 0 To UBound(sLine) ' does "Exif" exsist?
        ExifDate = InStr(1, sLine(i), "Exif")
        If ExifDate > 0 Then
            Found = True
            Exit For
        End If
    Next i
        
    If Found = False Then Exit Function ' return nothing, "Exif" not found!
    
    For d = i + 1 To UBound(sLine) ' find first ":" in file
    Debug.Print sLine(d)
        ExifDate = InStr(1, sLine(d), ":")
        If ExifDate > 0 Then
            FindPicDate = sLine(d) ' return date string
            Exit For
        End If
    Next d
            
End Function
 
Upvote 0
Still getting 4-23-2020



is what the Immediate window shows



II*











[1]












[1]

‑





Ñ





[1]

‑





ï





















(





[1]





1[1]







2[1]







5



;[1]







I



[1]









i‡





à



%ˆ





\



œœ

€





P



žœ





Ð



$



DCIM\100MEDIA\DJI_0857.JPG

DJI





















































FC300C















































H









H









v01.14.4920

























2020:04:23 11:03:37
 
Upvote 0
Bugger. So that method will not work in your case.

Hopefully someone else suggests a different method. Had a look at a few methods, but that was the only one I found that was successful for me.


Is there a file you can share for testing?
 
Upvote 0
Will this work?
 

Attachments

  • !1.JPG
    !1.JPG
    220.2 KB · Views: 6
Upvote 0
Perhaps, try this, you'll need to add Microsoft Scripting Runtime in Tools>References

1613945967955.png


*Gave me the last modified date tho

VBA Code: 
Sub listfiles()

Dim r As Integer, F As String, Directory As String

Directory = Application.DefaultFilePath _

& "\My Pictures\Old Building And Things\"



r = 1

Cells(r, 1) = "FileName"

Cells(r, 2) = "Size"

Cells(r, 3) = "Date Time"

Range("A1:c1").Font.Bold = True

'Get Directory

F = Dir(Directory)

Do While F <> ""

r = r + 1

Cells(r, 1) = F

Cells(r, 2) = FileLen(Directory & F)

Cells(r, 3) = FileDateTime(Directory & F)

''Cells(r, 4) = FindPicDate(Directory & F)

Cells(r, 4) = CreateObject("Scripting.FilesystemObject").GetFile(Directory & F).DateCreated

'Get next File

F = Dir()

Loop

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Display textbox from listbox - getting 381 error
Replies
4
Views
200
maiatanaka
M
M
  • Question
VBA search for specific file name in folders and their subfolders
Replies
7
Views
781
Candyman8019
C
H
  • Solved
Excel VBA file importing data from several files located in same folder -> challenge to copy data only (rest is working perfectly)
Replies
3
Views
117
NdNoviceHlp
NdNoviceHlp
A
  • Solved
Empty Folder Search...Need to Add Deeper Folder Levels to VBA Coding
Replies
4
Views
165
Micron
M
J
  • Question
How can I create a list from a single layer of a directory?
Replies
6
Views
306
PeteWright
PeteWright

Forum statistics

Threads
1,214,667
Messages
6,120,820
Members
448,990
Latest member
rohitsomani

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