Looking for a VB solution to change jpg "Date Taken" attribute

I did a quick google, and found a chap that seems to be editing the data taken field of image files using VB.net 2.0

I don't know if it will lead to anything for you, but you may be able to chat with him and get a snip of his vb code to help you out.

Here is the link to the forum thread where he is talking about what he created:

http://www.n95users.com/forum/camera/14713-how-copy-date-modified-file-tag-info-date-taken.html

What flavor of VB do you want to use for the conversion? vb6, .net ?

Here is a good article and example (I think) about editing the EXIF with VB

http://www.codeproject.com/KB/vb/exif_reader.aspx

Here is a project that you could disect and convert to VB

http://www.codeproject.com/KB/graphics/EXIF_tag_Editor.aspx

ok... one last post (sorry for posting in several responses, just posted as I found stuff.

This one has some info on it, but it sounds like your going to have a tough time of it after reading the comments at the end of the post...

http://www.codenewsgroups.net/group/microsoft.public.vb.general.discussion/topic11007.aspx

At the end you will notice the one guys response that:

[Quote]

    There can be different kinds of info. in a JPG,
with two systems for tagging information
embedded in the header. Camera companies
use EXIF to embed camera info. There are a
large number of documented EXIF encodings
that can be found online. (In other words, documented
byte markers to identify the beginning of specific
EXIF data.)

   Then there's IPTC, which was created as a standard
by the Newspaper Association of America (NAA)
and the International Press Telecommunications
Council (IPTC) as a way for photographers to save info.
like caption, description, copyright, etc.

   Each standard is only partially supported by
popular software. Microsoft has thrown a wrench into
the works by creating their own EXIF system that, unlike
standard EXIF, uses Unicode instead of ASCII text
strings.

   If you want to edit JPG properties in Explorer
then you probably mean the MS properties.  (Note
that there is probably no other software that will recognize
MS properties, and saving properties through
Explorer will probably lose any properties saved
by another method. Windows doesn't even recognize
IPTC, so it gets over-written when Explorer saves
a property its way.)

  You pretty much just have to parse the file header to
fish out the data, then rebuild the file bytes if you
want to save new strings. I don't know what the MS
byte markers are, offhand, but you'd need to first
look for an EXIF header and then look for a MS
marker in that.
[/quote]

Yes, Date Taken is part of the EXIF.

I will actually run the code either in VBA or VBscript, but I had figured that someone would be able to provide a VB method to access and then edit the Date Taken propetry. Without wanting to sound critical, I am looking to see an actual approach as opposed to the links on different informations snippets above. I've already googled this extensively

Cheers

Dave

Hi Dave,

The Scripting Guys tell you how to *get* the date picture taken property, but it requires Windows Desktop Search 3.0: http://www.microsoft.com/technet/scriptcenter/resources/qanda/jan07/hey0105.mspx

I'm not sure if that will let you change that value though....

I don't use Vista, so can't test this, but run this code, and see if you can identify which attribute number holds the Date picture taken (if any).

Regards,

Rob.

If LCase(Right(Wscript.FullName, 11)) = "wscript.exe" Then
    strPath = Wscript.ScriptFullName
    strCommand = "%comspec% /k cscript  """ & strPath & """"
    Set objShell = CreateObject("Wscript.Shell")
    objShell.Run(strCommand), 1, True
    Wscript.Quit
End If
 
strFile = "C:\Temp\ATT05728.gif"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(objFSO.GetFile(strFile).ParentFolder.Path)
If (Not objFolder Is Nothing) Then
	For Each strFileName In objFolder.Items
		If LCase(strFileName) = LCase(objFSO.GetFile(strFile).Name) Then
			For intItem = 0 To 266
				strResults = strResults & vbCrLf & "(" & intItem & ") " & objFolder.GetDetailsOf(objFolder.Items, intItem) & ": " & objFolder.GetDetailsOf(strFileName, intItem)
			Next
		End If
	Next
End If
Set objFolder = Nothing
Set objShell = Nothing
WScript.Echo strResults

Select allOpen in new window

Hi Rob,

Thx for the link, it looks like it just provides retrieval but I will looked further

I have used GetDetailsof before to get various file properties, and there is a useful table that I have stored somewhere that compares the attributes for XP v Vista. But again this method doesn't allow you to make changes to the actual data

There are a host of shareware programs that do this task, what surprises me is that there doesn't seem to be a quick kill coding approach.

BTW I've very much enjoyed your VBscript posts, especially in the Active Directory area which I'm starting to play with.

Cheers

Dave

Thanks Dave....I'm still learning about AD scripting, there's a lot more to it than I know of!  Some of my code on here is a bit shaky, and sometimes I see alternate methods around, and think "oh, I should have used that", but it's all part of the process!

Anyway, I have WDS 3.0 on a laptop here, so I'll check out whether it allows writes....

Regards,

Rob.

Hmmm, nope, the provider doesn't seem to support updating for WDS, and the GetDetailsOf method can't write to the file.

I wonder if there's a free ActiveX control around that could do it....

Rob.

Well, it looks a whole lot more involved than I thought.....here's a possible VB.Net implementation for viewing properties...
http://www.bobpowell.net/discoverproperties.htm

and here's a possible C++ implementation, although I'm not sure if that support writing either...
http://www.codeproject.com/KB/graphics/photoproperties.aspx

It just doesn't look promising, in terms of writing such info....

You could check out FStamp.exe from here: http://mail.nfbnet.org/download/file_utilities.htm
that you can use to change some file creation of modified dates....

Regards,

Rob.

Dave, this is your lucky day ;-)

Two VB routines: one for getting the date time taken, and one for setting the date time taken. No time for comments - honey do list is still long.

[Begin Code Segment]

Public Function GetPhotoDateTimeTaken( _
      ByVal FilePath As String _
   ) As Date
   
   Dim FileNumber As Long
   Dim FileData As String
   Dim ExifPos As Long
   Dim FileSection As String
   Dim RegExp As Object
   Dim Matches As Object
   Dim DateTimeValue As String
   
   FileNumber = FreeFile
   Open FilePath For Binary Access Read As FileNumber
   FileData = StrConv(InputB(4000, FileNumber), vbUnicode)
   Close FileNumber
   
   ExifPos = InStr(FileData, "Exif")
   If ExifPos = 0 Then Exit Function
   
   FileSection = Mid(FileData, ExifPos)
   Set RegExp = CreateObject("vbscript.regexp")
   RegExp.Global = True
   RegExp.MultiLine = True
   RegExp.IgnoreCase = True
   
   RegExp.Pattern = "[0-9]{4}:[0-9]{2}:[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2}\x00"
   
   On Error Resume Next
   Set Matches = RegExp.Execute(FileSection)
   On Error GoTo 0
   If Matches Is Nothing Then Exit Function
   If Matches.Count = 0 Then Exit Function
   
   DateTimeValue = Matches(0).Value
   GetPhotoDateTimeTaken = DateValue(Replace(Mid(DateTimeValue, 1, 10), ":", "/")) + TimeValue(Mid(DateTimeValue, 12, 8))

End Function

Public Function SetPhotoDateTimeTaken( _
      ByVal FilePath As String, _
      ByVal DateTimeTaken As Date _
   ) As Boolean
   
   Dim FileNumber As Long
   Dim FileData As String
   Dim ExifPos As Long
   Dim FileSection As String
   Dim RegExp As Object
   Dim Matches As Object
   Dim DateTimeValue As String
   
   FileNumber = FreeFile
   Open FilePath For Binary Access Read Write As FileNumber
   FileData = StrConv(InputB(4000, FileNumber), vbUnicode)
   
   ExifPos = InStr(FileData, "Exif")
   If ExifPos = 0 Then Exit Function
   
   FileSection = Mid(FileData, ExifPos)
   Set RegExp = CreateObject("vbscript.regexp")
   RegExp.Global = True
   RegExp.MultiLine = True
   RegExp.IgnoreCase = True
   
   RegExp.Pattern = "[0-9]{4}:[0-9]{2}:[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2}\x00"
   
   On Error Resume Next
   Set Matches = RegExp.Execute(FileSection)
   On Error GoTo 0
   If Matches Is Nothing Then Exit Function
   If Matches.Count = 0 Then Exit Function
   
   DateTimeValue = Left(Matches(0).Value, 19)
   FileData = Replace(FileData, DateTimeValue, Format(DateTimeTaken, "YYYY:MM:DD HH:MM:SS"))
   
   Seek FileNumber, 1
   Put FileNumber, , FileData
   Close FileNumber

   SetPhotoDateTimeTaken = True

End Function

[End Code Segment]

Kevin

Kevin....that's nice.....Do you know if it works for Windows XP?  I have just tested the Get and Set functions, and while they say they update the value (and Get reports to new value), Windows XP still shows the old value.....Perhaps this works for Vista?

Rob.

I tested it on XP with some photos taken with a Nikon D200.

Post your photo here and I'll see what the tags look like. The date taken tag sometimes occurs in multiple locations in the same file.

Kevin

Thanks.  Here's one.

Rob.
0001.jpg

That was taken with a Canon PowerShot A520

Ah, very nice! Well done!  Did you write those yourself?  How did you know what regex pattern to look for?

Anyway, that's very cool.  Works just fine when run from Microsoft Excel.

Thanks!  Now we'll just wait for Dave to test it, and see how it goes.

Rob.

Wrote them myself after a little research and poking around with a hex editor. RegExp patterns can be daunting - takes patience and some helper utilities:

   RegEx Coach Construction Tool: http://weitz.de/regex-coach/
   Expresso Construction Tool: http://www.ultrapico.com/Expresso.htm

Some other references:

   Basic Reference: http://www.regular-expressions.info/reference.html
   Advanced Reference: http://www.regular-expressions.info/refadv.html

Kevin

Oh, and the Binary Class came from here:
http://www.jsware.net/jsware/scripts.php5#jsbin

Regards,

Rob.

Looks good. I'm not as well versed in VBScript. It's unfortunate you have to read and write the whole file as photos can get large. But as long as the file I/O functions don't write any extra artifacts to the file you should be fine. During my testing I screwed up a few times and, when I did - even by inserting only one extra byte after the date, the Windows image previewer refused to display the image. So if the previewer displays the image then I would think the code works.

Kevin

Yeah, I'm not familiar with this time of operation, so it's touch and go for me, but as long as someone has a very good working version, the conversion usually goes pretty well.

I just noticed that instead of writing three times to the file, I can just write once.....but yeah, the class that I found doesn't appear to have the "seek" ability of VBA....

I changed these three lines:
      i = BO.WriteFileS(FilePath, Left(FileData, ExifPos - 1), True)
      i = BO.AppendFileS(FilePath, FileSection)
      i = BO.AppendFileS(FilePath, RestOfFile)

to this
      i = BO.WriteFileS(FilePath, Left(FileData, ExifPos - 1) & FileSection & RestOfFile, True)

and it seems to work fine.

Regards,

Rob.

dteDate = GetPhotoDateTimeTaken("C:\Temp\0001.jpg")
MsgBox dteDate
boolReturn = SetPhotoDateTimeTaken("C:\Temp\0001.jpg", Now)
MsgBox boolReturn
 
Public Function GetPhotoDateTimeTaken(ByVal FilePath)
   
	Dim FileNumber
	Dim FileData
	Dim ExifPos
	Dim FileSection
	Dim RegExp
	Dim Matches
	Dim DateTimeText
	Dim DateTimeValue
	Dim Index
   
	Set BO = New ClsBin  
	
	FileData = BO.Read(FilePath, 0, 4000)
	ExifPos = InStr(FileData, "Exif")
	If ExifPos = 0 Then Exit Function
   
	FileSection = Mid(FileData, ExifPos)
	Set RegExp = CreateObject("vbscript.regexp")
	RegExp.Global = True
	RegExp.MultiLine = True
	RegExp.IgnoreCase = True
   
	RegExp.Pattern = "[0-9]{4}:[0-9]{2}:[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2}\x00"
	
	On Error Resume Next
	Set Matches = RegExp.Execute(FileSection)
	On Error GoTo 0
	If Matches Is Nothing Then Exit Function
	If Matches.Count = 0 Then Exit Function
	
	For Index = 1 To Matches.Count
		DateTimeText = Matches(Index - 1).Value
		DateTimeValue = 0
		DateTimeValue = DateValue(Replace(Mid(DateTimeText, 1, 10), ":", "/")) + TimeValue(Mid(DateTimeText, 12, 8))
		If DateTimeValue > 0 And DateTimeValue < GetPhotoDateTimeTaken Or GetPhotoDateTimeTaken = 0 Then GetPhotoDateTimeTaken = DateTimeValue
	Next
 
End Function
 
Public Function SetPhotoDateTimeTaken(ByVal FilePath, ByVal DateTimeTaken)
   
	Dim FileNumber
	Dim FileData
	Dim ExifPos
	Dim FileSection
	Dim RegExp
	Dim Matches
 
	Set BO = New ClsBin  
	
	FileData = BO.Read(FilePath, 0, 4000)
	RestOfFile = BO.Read(FilePath, 4001, BO.GetSize(FilePath) - 4001)
	ExifPos = InStr(FileData, "Exif")
	If ExifPos = 0 Then Exit Function
   
	FileSection = Mid(FileData, ExifPos)
	Set RegExp = CreateObject("vbscript.regexp")
	RegExp.Global = True
	RegExp.MultiLine = True
	RegExp.IgnoreCase = True
   
	RegExp.Pattern = "[0-9]{4}:[0-9]{2}:[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2}\x00"
   
	On Error Resume Next
	Set Matches = RegExp.Execute(FileSection)
	On Error GoTo 0
	If Matches Is Nothing Then Exit Function
	If Matches.Count = 0 Then Exit Function
 
	' Format DateTimeTaken to "YYYY:MM:DD HH:MM:SS"
	DateTimeTaken = Year(DateTimeTaken) & ":" & Right("0" & Month(DateTimeTaken), 2) & ":" & Right("0" & Day(DateTimeTaken), 2) & _
		" " & Right("0" & Hour(DateTimeTaken), 2) & ":" & Right("0" & Minute(DateTimeTaken), 2) & ":" & Right("0" & Second(DateTimeTaken), 2)
	FileSection = RegExp.Replace(FileSection, DateTimeTaken & Chr(0))
	
	i = BO.WriteFileS(FilePath, Left(FileData, ExifPos - 1) & FileSection & RestOfFile, True)
	'i = BO.AppendFileS(FilePath, FileSection)
	'i = BO.AppendFileS(FilePath, RestOfFile)
 
	SetPhotoDateTimeTaken = True
 
End Function
 
'==============================================
'==============================================
'================ FROM JSWARE =================
'==============================================
'==============================================
'-- ClsBin Class without comments, for pasting.
Class ClsBin
   Private FSO, i, TS, sAst, ANums, Char1
   
  Private Sub Class_Initialize()
       sAst = "*"
       Char1 = Chr(1)
      Set FSO = CreateObject("Scripting.FileSystemObject")
  End Sub
          
  Private Sub Class_Terminate()
      Set TS = Nothing   '-- just in case.
      Set FSO = Nothing
  End Sub
 
Public Function GetSize(sFilePath)
  Dim OFil
   If (FSO.FileExists(sFilePath) = False) Then
       GetSize = -1
       Exit Function
   End If
     Set OFil = FSO.GetFile(sFilePath)
       GetSize = OFil.Size
     Set OFil = Nothing
End Function
 
Public Function Read(sFilePath, StartPt, LenR)
Dim LenF
   On Error Resume Next
     Read = ""
       If (FSO.FileExists(sFilePath) = False) Then Exit Function
     LenF = GetSize(sFilePath)
       If (StartPt >= LenF) Then Exit Function   
      If (StartPt < 1) Then StartPt = 1    
      If (LenR = 0) Then LenR = LenF        
     Set TS = FSO.OpenTextFile(sFilePath, 1)            
         If (StartPt > 1) Then TS.Skip (StartPt - 1)
         Read = TS.Read(LenR)
         TS.Close
     Set TS = Nothing                                                       
End Function
 
Public Function WriteFileA(sFilePath, ArrayIn, OverWrite)
 Dim sA1, iA1
     On Error Resume Next
       If (FSO.FileExists(sFilePath) = True) Then
          If (OverWrite = True) Then
              FSO.DeleteFile sFilePath, True
           Else
              WriteFileA = 1  '-- file exists.
              Exit Function
           End If  
       End If
       If IsArray(ArrayIn) = False Then
           WriteFileA = 2    '-- ArrayIn value is not an array.
           Exit Function
      End If  
   Err.Clear   
    For iA1 = 0 to UBound(ArrayIn)
        ArrayIn(iA1) = Chr(ArrayIn(iA1))
    Next    
       sA1 = Join(ArrayIn, "")
       
      Set TS = FSO.CreateTextFile(sFilePath, True)
         TS.Write sA1
         TS.Close
      Set TS = Nothing
    WriteFileA = Err.Number 
End Function
 
Public Function WriteFileS(sFilePath, StringIn, OverWrite)
 Dim sA1, iA1
     On Error Resume Next
       If (FSO.FileExists(sFilePath) = True) Then
           If (OverWrite = True) Then
               FSO.DeleteFile sFilePath, True
           Else
              WriteFileS = 1  '-- file exists.
              Exit Function
           End If  
       End If
   Err.Clear   
      Set TS = FSO.CreateTextFile(sFilePath, True)
         TS.Write StringIn
         TS.Close
      Set TS = Nothing                                
    WriteFileS = Err.Number    '-- return 0 if no errors.
End Function
 
Public Function AppendFileA(sFilePath, ArrayIn)
    Dim sA1, iA1
     On Error Resume Next
         If (FSO.FileExists(sFilePath) = False) Then
             AppendFileA = 1  '-- file does not exist.
             Exit Function
         End If 
          If IsArray(ArrayIn) = False Then
              AppendFileA = 2    '-- ArrayIn value is not an array.
              Exit Function
          End If  
   Err.Clear    
      For iA1 = 0 to UBound(ArrayIn)
          ArrayIn(iA1) = Chr(ArrayIn(iA1))
      Next    
         sA1 = Join(ArrayIn, "")
        
      Set TS = FSO.OpenTextFile(sFilePath, 8)
         TS.Write sA1
         TS.Close
      Set TS = Nothing
    AppendFileA = Err.Number 
End Function
 
Public Function AppendFileS(sFilePath, StringIn)
     On Error Resume Next
         If (FSO.FileExists(sFilePath) = False) Then
             AppendFileS = 1  '-- file does not exist.
             Exit Function
         End If 
   Err.Clear    
      Set TS = FSO.OpenTextFile(sFilePath, 8)
         TS.Write StringIn
         TS.Close
      Set TS = Nothing
  AppendFileS = Err.Number 
End Function
 
Public Function GetByteString(sStr, KeepZeros, SnipUnicode)
  Dim sRet, iLen, iA, iLen2, A2()
      iLen2 = 0
      ReDim A2(len(sStr))
   If (SnipUnicode = False) Then
        For iLen = 1 to Len(sStr)
            iA = Asc(Mid(sStr, iLen, 1))
            If (KeepZeros = True) Then
                If iA = 0 Then iA = 42
            End If
              If (iA <> 0) Then 
                 A2(iLen2) = Chr(iA)
                 iLen2 = iLen2 + 1
             End If
        Next
   Else     
       For iLen = 1 to Len(sStr) step 2
             iA = Asc(Mid(sStr, iLen, 1))
           If (KeepZeros = True) Then
                If iA = 0 Then iA = 42  '-- converts 0-byte to *
           End If
            If (iA <> 0) Then 
                A2(iLen2) = Chr(iA)
                iLen2 = iLen2 + 1
            End If          
       Next  
   End If     
       ReDim Preserve A2(iLen2 - 1)
       GetByteString = Join(A2, "")
End Function
 
Function GetArray(sStr, SnipUnicode)
Dim iA, Len1, Len2, AStr()
  On Error Resume Next
  Len1 = Len(sStr)
   If (SnipUnicode = True) Then 
      ReDim AStr((Len1 \ 2) - 1)
   Else
     ReDim AStr(Len1 - 1)
   End If      
 
   If (SnipUnicode = True) Then 
          For iA = 1 to Len1 step 2
             AStr(iA - 1) = Asc(Mid(sStr, iA, 1))
         Next    
   Else
         For iA = 1 to Len1
             AStr(iA - 1) = Asc(Mid(sStr, iA, 1))
         Next      
   End If  
      GetArray = AStr    
End Function
'-------------------- return a number from 4 bytes. ---------------
Public Function GetNumFrom4Bytes(A4)
   Dim Num1
       On Error Resume Next
     If (UBound(A4) <> 3) Then
        GetNumFrom4Bytes = 0
        Exit Function
     End If   
        Num1 = A4(0) + (A4(1) * 256)
        Num1 = Num1 + (A4(2) * 65536)
        Num1 = Num1 + (A4(3) * 16777216)
     If Err.number = 0 Then
         GetNumFrom4Bytes = Num1
     Else
         GetNumFrom4Bytes = -1
     End If
End Function
 
Public Function GetNumFrom2Bytes(A2B)
   Dim Num1
       On Error Resume Next
     If (UBound(A2B) <> 1) Then
        GetNumFrom2Bytes = 0
        Exit Function
     End If   
        Num1 = A2B(0) + (A2B(1) * 256)
    GetNumFrom2Bytes = Num1
End Function
 
Public Function ConvertToBase64(sBytes, AddReturns)
  Dim B2(), B76(), ABytes()
  Dim i1, i2, i3, LenA, NumReturns, sRet
     On Error Resume Next
  If Not IsArray(ANums) Then
     ANums = Array(65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 43, 47)
  End If
     LenA = Len(sBytes)
     ReDim ABytes(LenA - 1)
       For i1 = 1 to LenA
           ABytes(i1 - 1) = Asc(Mid(sBytes, i1, 1))
       Next  
  ReDim Preserve ABytes(((LenA - 1) \ 3) * 3 + 2) 
  ReDim Preserve B2((UBound(ABytes) \ 3) * 4 + 3) 
     i2 = 0
        For i1 = 0 To (UBound(ABytes) - 1) Step 3
            B2(i2) = ANums(ABytes(i1) \ 4)
              i2 = i2 + 1
            B2(i2) = ANums((ABytes(i1 + 1) \ 16) Or (ABytes(i1) And 3) * 16)
              i2 = i2 + 1
            B2(i2) = ANums((ABytes(i1 + 2) \ 64) Or (ABytes(i1 + 1) And 15) * 4)
              i2 = i2 + 1
            B2(i2) = ANums(ABytes(i1 + 2) And 63)
              i2 = i2 + 1
        Next 
            For i1 = 1 To i1 - LenA
               B2(UBound(B2) - i1 + 1) = 61
            Next 
            
   If (AddReturns = True) And (LenA > 76) Then
        NumReturns = ((UBound(B2) + 1) \ 76)
        LenA = (UBound(B2) + (NumReturns * 2)) 
         ReDim B76(LenA)
          i2 = 0
          i3 = 0
              For i1 = 0 To UBound(B2)
                   B76(i2) = B2(i1)
                    i2 = i2 + 1
                    i3 = i3 + 1
                       If (i3 = 76) And (i2 < (LenA - 2)) Then  
                          B76(i2) = 13              
                          B76(i2 + 1) = 10
                          i2 = i2 + 2
                          i3 = 0
                       End If
              Next
           
        For i1 = 0 to UBound(B76)
            B76(i1) = Chr(B76(i1))
        Next        
          sRet = Join(B76, "")
   Else
        For i1 = 0 to UBound(B2)
            B2(i1) = Chr(B2(i1))
        Next  
          sRet = Join(B2, "")
   End If
       ConvertToBase64 = sRet
End Function
 
Public Function DecodeBase64(Str64)
  Dim B1(), B2()
  Dim i1, i2, i3, LLen, UNum, s2, sRet
  Dim A255(255)
    On Error Resume Next
   If Not IsArray(ANums) Then
     ANums = Array(65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 43, 47)
   End If
 
    For i1 = 0 To 255
       A255(i1) = 64
    Next
    For i1 = 0 To 63
       A255(ANums(i1)) = i1
    Next
          s2 = Replace(Str64, VBCrLf, "")
          LLen = Len(s2)
         ReDim B1(LLen - 1)
      For i1 = 1 to LLen
          B1(i1 - 1) = Asc(Mid(s2, i1, 1)) 
      Next      
 
  '--B1 is now in-string as array.
   ReDim B2((LLen \ 4) * 3 - 1)
        i2 = 0
     For i1 = 0 To UBound(B1) Step 4
        B2(i2) = (A255(B1(i1)) * 4) Or (A255(B1(i1 + 1)) \ 16)
           i2 = i2 + 1
        B2(i2) = (A255(B1(i1 + 1)) And 15) * 16 Or (A255(B1(i1 + 2)) \ 4)
           i2 = i2 + 1
        B2(i2) = (A255(B1(i1 + 2)) And 3) * 64 Or A255(B1(i1 + 3))
           i2 = i2 + 1
     Next
        If B1(LLen - 2) = 61 Then
           i2 = 2
        ElseIf B1(LLen - 1) = 61 Then
           i2 = 1
        Else
           i2 = 0
        End If
        UNum = UBound(B2) - i2
     ReDim Preserve B2(UNum)
       For i1 = 0 to UBound(B2)
         B2(i1) = Chr(B2(i1))
       Next   
        DecodeBase64 = Join(B2, "")
End Function
 
Public Function GetVersionInfo(sFilePath, ARet2)  '-- return array(5)
Dim ARet, s1, s2, sB, Pt1, Pt2, sRes, A1, A4(3), A2(1), LocRes, VLocRes, SizeRes, iOffSet, Boo, sVerString
Dim iNum1, iNum2, iReadPt, iNum3, LocAspack, VLocAspack, VIOffset, ReadOffset, BooAspack
     On Error Resume Next
               If (FSO.FileExists(sFilePath) = False) Then
                    GetVersionInfo = 1  'bad path.
                    Exit Function
               End If
       sRes = ".rsrc"
       sVerString = "VS_VER"
       BooAspack = False
           
       s1 = Read(sFilePath, 1, 2048) '-- Read first 2 KB.
        A1 = GetArray(Mid(s1, 61, 2), False)  '-- get number value at offset 60 that points to PE signature address.
        iNum1 = (GetNumFrom2Bytes(A1) + 1)     '-- get offset of "PE00"
       sB = GetByteString(s1, True, False)  '-- get a workable string with Chr(0) replaced by "*".       
          If Mid(sB, iNum1, 4) <> "PE**" Then
               GetVersionInfo = 4  '-- no PE signature found.
               Exit Function 
          End If
          
        Pt1 = InStr(1, sB, sRes)   '-- find .rsrc table.
               If (Pt1 = 0) Then   
                   GetVersionInfo = 2  'no resource table header found.
                   Exit Function
               End If
        Pt1 = Pt1 + 12  '--  size of raw data is 4 bytes at offset of 16 into the .rsrc table. 
         A1 = GetArray(Mid(s1, Pt1, 12), False)  
               For iOffSet = 0 to 3
                  A4(iOffSet) = A1(iOffSet)
               Next
                 VLocRes = GetNumFrom4Bytes(A4) 
               For iOffSet = 0 to 3
                  A4(iOffSet) = A1(iOffSet + 4)
               Next
          SizeRes = GetNumFrom4Bytes(A4) 
                 For iOffSet = 0 to 3
                    A4(iOffSet) = A1(iOffSet + 8)
                 Next
          LocRes = GetNumFrom4Bytes(A4)   
                        Pt1 = InStr(1, sB, ".aspack")   '-- find .rsrc table.
                          If (Pt1 > 0) Then
                                  BooAspack = True
                                      Pt1 = Pt1 + 12   '--  size of raw data is 4 bytes at offset of 16 into the .rsrc table. 
                                      A1 = GetArray(Mid(s1, Pt1, 12), False)  
                                   For iOffSet = 0 to 3
                                      A4(iOffSet) = A1(iOffSet)
                                   Next
                                     VLocAspack = GetNumFrom4Bytes(A4) 
                                   For iOffSet = 0 to 3
                                      A4(iOffSet) = A1(iOffSet + 8)
                                   Next
                                     LocAspack = GetNumFrom4Bytes(A4) 
                          End If    
    Boo = False
      Set TS = FSO.OpenTextFile(sFilePath, 1)
      TS.Skip LocRes + 12 
      s1 = TS.Read(2)      
      iNum1 = Asc(s1)      
      s1 = TS.Read(2)      
      iNum2 = Asc(s1)   
       If (iNum2 = 0) Then 
             TS.Close
             Set TS = Nothing
             GetVersionInfo = 3  'failed to find version info in resource table.
             Exit Function
       End If
        If (iNum1 > 0) Then TS.Skip (iNum1 * 8) '-- Skip past named entries.
       iReadPt = LocRes + 16 + (iNum1 * 8)  '-- update file offset variable because this will be needed.
         Boo = False
    For iOffSet = 1 to iNum2
       s1 = TS.Read(8)
       iReadPt = iReadPt + 8
          If (Asc(s1) = 16) Then  '-- this is version info. entry.
                Boo = True
                Exit For
          End If
     Next
         If (Boo = False) Then  '-- have to quit. no version info. entry found.
             TS.Close
             Set TS = Nothing
             GetVersionInfo = 3  'failed to find version info in resource table.
             Exit Function
         End If   
       A1 = GetArray(s1, False)  '-- get a byte array for version info entry at top level.
       iOffSet = 0
       iNum3 = 1
    Do
       For iNum1 = 0 to 2 
          A4(iNum1) = A1(iNum1 + 4)
       Next
           A4(3) = 0
           iNum2 = GetNumFrom4Bytes(A4)
          
         If (A1(7) > 127) Then  '-- high bit was set in entry offset value, so it's just a pointer to another pointer.    
             iNum2 = LocRes + iNum2 + 16
             TS.Skip (iNum2 - iReadPt)   '- 1)
             s1 = TS.Read(8)
             iReadPt = iReadPt + ((iNum2 - iReadPt) + 8)
             A1 = GetArray(s1, False)
         Else  '-- this is the offset of version info offset info.! 
              iOffSet = (iNum2 + LocRes)
              Exit Do
         End If
        iNum3 = iNum3 + 1
        If (iNum3 > 10) Then Exit Do
    Loop    
         If (iOffSet = 0) Then  '-- have to quit. no final offset found.       
             TS.Close
             Set TS = Nothing
             GetVersionInfo = 3  'failed to find version info in resource table.
             Exit Function
        End If
    TS.Skip (iOffSet - iReadPt) '- 1)
     s1 = TS.Read(8)
     iReadPt = iReadPt + ((iOffSet - iReadPt) + 8)
     A1 = GetArray(s1, False)
       For iNum1 = 0 to 3
         A4(iNum1) = A1(iNum1)
       Next   
        VIOffset = GetNumFrom4Bytes(A4)  '--offset of version info. given in .rsrc section.
        ReadOffset = ((VIOffset - VLocRes) + LocRes)
       For iNum1 = 0 to 3
         A4(iNum1) = A1(iNum1 + 4)
       Next      
         SizeRes = GetNumFrom4Bytes(A4)
    TS.Skip (ReadOffset - iReadPt)
       s1 = TS.Read(SizeRes)  '-- read out the entire FileVersionInfo data area.
       TS.Close
     Set TS = Nothing
     
      sB = GetByteString(s1, True, True) '-- snip unicode; leave 0s for parsing but convert them to *
      
 Pt1 = InStr(1, sB, sVerString)                                                           
           If (Pt1 > 0) Then        '-- "VS_VER" was found, so process the string and quit.
                ARet = ProcessRes(sB)     
                ARet2 = ARet
                GetVersionInfo = 0  ' ok            
           ElseIf (BooAspack = True) Then  
              ReadOffset = ((VIOffset - VLocAspack) + LocAspack) 
              
                Set TS = FSO.OpenTextFile(sFilePath, 1) 
                   TS.Skip ReadOffset                           
                     s1 = TS.Read(SizeRes)                   
                   TS.Close                                 
                Set TS = Nothing                       
                   sB = GetByteString(s1, True, True) 
                   Pt1 = InStr(1, sB, sVerString) 
                     If (Pt1 > 0) Then        
                        ARet = ProcessRes(sB)     
                        ARet2 = ARet
                        GetVersionInfo = 0  ' ok
                     Else   
                        GetVersionInfo = 3  'failed to find version info in resource table.
                     End If  
           Else   
                 GetVersionInfo = 3  'failed to find version info in resource table.         
           End If
End Function  
 
Private Function ProcessRes(sDat)
  Dim AInfo(5)
      On Error Resume Next
      AInfo(0) = GetInfo(sDat, "CompanyName")
      AInfo(1) = GetInfo(sDat, "FileDescription") 
      AInfo(2) = GetInfo(sDat, "FileVersion")
      AInfo(3)  = GetInfo(sDat, "ProductName")
      AInfo(4) = GetInfo(sDat, "LegalCopyright")
      AInfo(5) = GetInfo(sDat, "OriginalFilename")
    ProcessRes = AInfo  
End Function
 
Private Function GetInfo(sStr, sVal)
  Dim Pta, Ptb, LenVal, s4
       On Error Resume Next
         GetInfo = ""
    LenVal = Len(sVal) + 1  
     Pta = InStr(1, sStr, sVal) 
       If (Pta > 0) Then
          Pta = Pta + LenVal
          Ptb = InStr((Pta + 1), sStr, sAst)   
            If Ptb > (Pta + 2) Then                 
               s4 = Mid(sStr, Pta, (Ptb - Pta))   
               s4 = Replace(s4, sAst, "")                                    
              If InStr(1, s4, Char1, 0) = 0 Then GetInfo = s4  
           End If                         
      End If 
End Function
End Class

Select allOpen in new window

Kevin

Many thx - I don't think I'm exaggerating when I call this groundbreaking.  I am eagerly looking forward to testing this when I get home. I am particularly impressed that you snuck in a regexp

I was going to poke around with a hex editor to see if I could extract the EXIF header but I didn't fancy my chances.

Now that MS has killed filesearch I'll be adding this onto your recursive file code that I lifted from your MP3 example. I owe you a few beers

Rob,

Thx for your input as well, much appreciated

In addition to Kevin's regexp links you may find my VBA worked examples at http://vbaexpress.com/kb/getarticle.php?kb_id=68 of interest

Cheers

Dave

Don't get too excited...it's not exactly a pristine solution. There is little documentation and what I did find suggests that the standards for the header content is sketchy and loosely followed. On a scale of 1 to 10 where 1 is a hack and 10 is perfection, my solution is an effective 2 at best.

Kevin

I have read that there are a couple of header standards, so I may need to adapt it for my canon  ..... but if it works then I don't mind if its an ugly baby. I'd pretty much given this one away till you stepped in

But the important question is   ........ why aren't you sleeping?

This worked a treat on a Pentax A20 machine that I had on my work XP machine. I will run it over my affected files tonight (post backup) and then post the final code in case anyone else has the same problem

I had a look at the file with a hex editor, all three dates were indentical.  Not much other EXIF data was readily apparent other than camera make and date taken.

Good stuff, much appreciated

Cheers

Dave

It's 10/10 from my perspective. thx Kevin

Agreed. Fantastic work Kevin....I'm not keen on hex editors and probably would have put that in the "too hard" basket had I required such a function, but you've persisted, and it works well (even if it is a sketchy 2....)

Dave, are you using this from VBA, or as VBScript?

Regards,

Rob.

Rob,

I'm running it from VBA, but I intend to look at your VBS as well

I have just run the code with a 90% success rate, some of the files appear to have a different EXIF date structure. I will investigate shortly - have to do some actual day work first - and then will post the findings

Cheers

Dave

Final code for anyone else who comes accross this - pls note the warning at the top

I increased
FileData = BO.Read(FilePath, 0, 4000)
to
FileData = BO.Read(FilePath, 0, 14000)

and every JPG was successfully modified

Regards

Dave

Public Const BadDate = 2008
Public Const DayAdd = 954
' Warning
' *************************************************************************
' Running this code will increment the 'date taken' property of any jpg file
' in the following folders by 954 days if the jpg DOES NOT have a current
' "date taken" year of 2008.
' 1) The selected Folder
' 2) Any sub folders
' *************************************************************************
 
 
Sub GetFiles()
    Dim myDir As String
    Dim ws As Worksheet
    Application.ScreenUpdating = False
    myDir = BrowseForFolder
    If myDir = vbNullString Then
        Debug.Print "No folder selected."
        Exit Sub
    End If
 
    Set ws = ActiveWorkbook.Sheets.Add
    ws.[a1] = "Picture"
    ws.[b1] = "Date Taken - Prior"
    ws.[c1] = "Date Taken - Adjusted"
 
    ListExcelFiles (myDir)
 
    Application.StatusBar = ""
    Application.ScreenUpdating = True
End Sub
 
 
 
Public Sub ListExcelFiles(ByVal Folder As Variant)
    Dim FileName As String
    Dim Folders As Collection
    Dim IsDirectory As Boolean
    Dim i As Long
 
    FileName = Dir(Folder & "\*.*", vbNormal + vbDirectory)
    Do While Len(FileName) > 0
        If Not FileName = "." And Not FileName = ".." Then
            Application.StatusBar = Left("Processing " & Folder & "\" & FileName, 255)
            On Error Resume Next
            IsDirectory = False
            IsDirectory = GetAttr(Folder & "\" & FileName) And vbDirectory
            On Error GoTo 0
            If IsDirectory Then
                If Folders Is Nothing Then Set Folders = New Collection
                Folders.Add Folder & "\" & FileName & "\"
            ElseIf LCase(Right(FileName, 4)) Like ".jpg" Then
                ListFileDetails Folder, FileName
            End If
        End If
        FileName = Dir
    Loop
    If Not Folders Is Nothing Then
        For Each Folder In Folders
            ListExcelFiles Folder
        Next Folder
    End If
End Sub
 
Public Sub ListFileDetails(ByVal Folder As String, ByVal FileName As String)
    Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Offset(1, 0) = FileName
    Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Offset(1, 0) = GetPhotoDateTimeTaken(Folder & "/" & FileName)
End Sub
 
Public Function GetPhotoDateTimeTaken( _
       ByVal FilePath As String _
     ) As Date
 
    Dim FileNumber As Long
    Dim FileData As String
    Dim ExifPos As Long
    Dim FileSection As String
    Dim RegExp As Object
    Dim Matches As Object
    Dim DateTimeText As String
    Dim DateTimeValue As Date
    Dim Index As Long
    Dim Processed As Boolean
 
    FileNumber = FreeFile
    Open FilePath For Binary Access Read As FileNumber
    FileData = StrConv(InputB(14000, FileNumber), vbUnicode)
    Close FileNumber
 
    ExifPos = InStr(FileData, "Exif")
    If ExifPos = 0 Then Exit Function
 
    FileSection = Mid(FileData, ExifPos)
    Set RegExp = CreateObject("vbscript.regexp")
    RegExp.Global = True
    RegExp.MultiLine = True
    RegExp.IgnoreCase = True
 
    RegExp.Pattern = "[0-9]{4}:[0-9]{2}:[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2}\x00"
 
    On Error Resume Next
    Set Matches = RegExp.Execute(FileSection)
    On Error GoTo 0
    If Matches Is Nothing Then Exit Function
    If Matches.Count = 0 Then Exit Function
 
    For Index = 1 To Matches.Count
        DateTimeText = Matches(Index - 1).Value
        DateTimeValue = 0
        DateTimeValue = DateValue(Replace(Mid(DateTimeText, 1, 10), ":", "/")) + TimeValue(Mid(DateTimeText, 12, 8))
        If DateTimeValue > 0 And DateTimeValue < GetPhotoDateTimeTaken Or GetPhotoDateTimeTaken = 0 Then GetPhotoDateTimeTaken = DateTimeValue
    Next Index
    If Year(GetPhotoDateTimeTaken) < BadDate Then Processed = SetPhotoDateTimeTaken(FilePath, DateAdd("d", DayAdd, GetPhotoDateTimeTaken))
End Function
 
Public Function SetPhotoDateTimeTaken( _
       ByVal FilePath As String, _
       ByVal DateTimeTaken As Date _
     ) As Boolean
 
    Dim FileNumber As Long
    Dim FileData As String
    Dim ExifPos As Long
    Dim FileSection As String
    Dim RegExp As Object
    Dim Matches As Object
 
    FileNumber = FreeFile
    Open FilePath For Binary Access Read Write As FileNumber
    FileData = StrConv(InputB(14000, FileNumber), vbUnicode)
 
    ExifPos = InStr(FileData, "Exif")
    If ExifPos = 0 Then Exit Function
 
    FileSection = Mid(FileData, ExifPos)
    Set RegExp = CreateObject("vbscript.regexp")
    RegExp.Global = True
    RegExp.MultiLine = True
    RegExp.IgnoreCase = True
 
    RegExp.Pattern = "[0-9]{4}:[0-9]{2}:[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2}\x00"
 
    On Error Resume Next
    Set Matches = RegExp.Execute(FileSection)
    On Error GoTo 0
    If Matches Is Nothing Then Exit Function
    If Matches.Count = 0 Then Exit Function
 
    FileSection = RegExp.Replace(FileSection, Format(DateTimeTaken, "YYYY:MM:DD HH:MM:SS") & Chr(0))
    
    Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Offset(0, 1) = FileSection
 
    Seek FileNumber, ExifPos
    Put FileNumber, , FileSection
    Close FileNumber
 
    SetPhotoDateTimeTaken = True
 
End Function
 
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose:  To Browser for a user selected folder.
 
 
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE:  If invalid, it will open at the Desktop level
 
    Dim ShellApp As Object
 
    'Create a file browser window at the default folder
    Set ShellApp = CreateObject("Shell.Application"). _
                   BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
    'Set the folder to that selected.  (On error in case cancelled)
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
 
    'Destroy the Shell Application
    Set ShellApp = Nothing
 
    'Check for invalid or non-entries and send to the Invalid error
    'handler if found
    'Valid selections can begin L: (where L is a letter) or
    '\\ (as in \\servername\sharename.  All others are invalid
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
 
    Exit Function
 
Invalid:
    'If it was determined that the selection was invalid, set to False
    BrowseForFolder = False
End Function

Select allOpen in new window