' ========================================================================================================
'
' Script for moving/cataloguing image files based on the date the picture was taken
' Are Westby 062106
'
' Changelog:
'
' 1.0 Sorts, creates folders and moves files to relevant folders based on DatePictureTaken EXIF header (25)
'
' ToDo:
'
' * Integrate recursive folder search (currently, all images must reside in one folder (defined in oFolder and Folder))
' * Create inputbox allowing user to specify EXIF (or other) parameters as base for sorting
' * Add error checking and conditions for files without headers, and alternate sorting
' * Clean up code ;)
' * Switch to less ugly date hack
'
' ========================================================================================================
' Start script
'
' Variables and constants
Set Fso = CreateObject("Scripting.Filesystemobject")
Set Folder = Fso.GetFolder("C:\Documents and Settings\Maren\Mine dokumenter\Bilder\bygninger")
Set Shell = CreateObject("Shell.Application")
Set oFolder = Shell.Namespace("C:\Documents and Settings\Maren\Mine dokumenter\Bilder\bygninger")
Const adVarChar = 200
' Create and open recordset, and populate arrays
Set Rs = CreateObject("ADOR.Recordset")
Rs.Fields.Append "filename",adVarChar,255
Rs.Fields.Append "createdate",adVarChar,255
Rs.Open
For each f in oFolder.Items
FDate = oFolder.GetDetailsOf(f,25)
Rs.AddNew array("filename","createdate"), _
array(f.name, fdate)
Rs.Update
Next
' Start loop
If not (Rs.BOF and Rs.EOF) Then
Rs.Sort = "createdate desc"
Rs.Movefirst
Do until rs.eof
' Create monthly folders, and trim foldernames to "yyyy.mm"
FCreateDate = Rs.Fields("createdate")
FileName = Folder & "\" & Rs.Fields("filename")
FolderDate = Folder & "\" & Mid(FCreateDate,7,4) & "." & Mid(FCreateDate,4,2) & "\"
If Fso.FolderExists(FolderDate)=false then
Fso.CreateFolder(FolderDate)
End If
' Move each file to related folder
Fso.Movefile Filename, FolderDate
Rs.Movenext
Loop
End If
' Close
Set Rs = nothing
Set Folder = nothing
Set Fso = nothing
Set Shell = nothing
Set oFolder = nothing
' ========================================================================================================