Solved

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

Posted on 2008-11-02
31
3,232 Views
Last Modified: 2011-10-19
I have a series of jpg's where the digital camera has stored an incorrect date. I want to update this atribute by simply adding a time to the jpg's in question. I have already developed the  recursive code to look at all the affected files in the folder tree, but I have not been able to locate a dll that will let me edit the "date taken" attribute.  For example I looked at dsofil but "date taken" is not one of the editable properties

Pls note that I have already looked at software solutions that offer batch updating and I don't want to pursue these options - I am interested only in a VB based solution.

Regards

Dave
0
Comment
Question by:Dave Brett
  • 12
  • 8
  • 6
  • +1
31 Comments
 

Expert Comment

by:MiSheps
Comment Utility
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
0
 

Expert Comment

by:MiSheps
Comment Utility
What flavor of VB do you want to use for the conversion? vb6, .net ?
0
 

Expert Comment

by:MiSheps
Comment Utility

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

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

Expert Comment

by:MiSheps
Comment Utility
Here is a project that you could disect and convert to VB

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

Expert Comment

by:MiSheps
Comment Utility
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]
0
 
LVL 50

Author Comment

by:Dave Brett
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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

Open in new window

0
 
LVL 50

Author Comment

by:Dave Brett
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Thanks.  Here's one.

Rob.
0001.jpg
0
What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
That was taken with a Canon PowerShot A520
0
 
LVL 81

Accepted Solution

by:
zorvek (Kevin Jones) earned 450 total points
Comment Utility
I found three dates in your pic and mine. In mine they were all the same. In yours one was later and it appears to be placed there by a photo editor. I changed the routines to accommodate. There is one caveat: since I don't know which date is which I change all found.

[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 DateTimeText As String
   Dim DateTimeValue As Date
   Dim Index As Long
   
   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
   
   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

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(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
   
   FileSection = RegExp.Replace(FileSection, Format(DateTimeTaken, "YYYY:MM:DD HH:MM:SS") & Chr(0))
   
   Seek FileNumber, ExifPos
   Put FileNumber, , FileSection
   Close FileNumber

   SetPhotoDateTimeTaken = True

End Function

[End Code Segment]

Kevin
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
Comment Utility
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
0
 
LVL 65

Assisted Solution

by:RobSampson
RobSampson earned 50 total points
Comment Utility
OK, well that's pure awesome! Nicely done!

Well, I'm not very good at this, but I think I just converted the functions for use with pure VBScript.  You might like to check out the way I've written the file in the Set function....not too sure if I've done that correctly.  Here's hoping I haven't corrupted the file.

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), 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

Open in new window

0
 
LVL 65

Expert Comment

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

Regards,

Rob.
0
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
Comment Utility
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
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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

Open in new window

0
 
LVL 50

Author Comment

by:Dave Brett
Comment Utility
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
0
 
LVL 81

Expert Comment

by:zorvek (Kevin Jones)
Comment Utility
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
0
 
LVL 50

Author Comment

by:Dave Brett
Comment Utility
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?
0
 
LVL 50

Author Comment

by:Dave Brett
Comment Utility
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
0
 
LVL 50

Author Closing Comment

by:Dave Brett
Comment Utility
It's 10/10 from my perspective. thx Kevin
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
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.
0
 
LVL 50

Author Comment

by:Dave Brett
Comment Utility
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



0
 
LVL 50

Author Comment

by:Dave Brett
Comment Utility
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

Open in new window

0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now