Digital Photos SD stick getting Bigger and Bigger

Take a Photo now a days you seen not to run out of film have a 12GB one put in the Photo Frame and a 2GB one in my camera

My problem is I hate renaming photos last count over 9,000 photo

so hes a script I wrote to take all images in a folder look at the Last Modified date and Create a Year folder then the Month folder and copy the file there. ¹ FSO.Deletefile(file)

'************************************************
'
' Copyright MYLE 2010
'
' This will copy all file and subfolder from Your Photo Location
' and rename then to a number as the photo frame does not care for File Name
' AS you could have File with the Same name in a Differance folder.
' You Need to Setup 5 thing
' 1. StartFrom    where are the Photos
' 2. CopyTo       Which Drive is the Stick in
' 3. EXT_OK       What ext do you want to copy over.
' 4. LenEDI       Just leave this at 7 if you have more than
' 5. Deletefile   Delete file after move  true/false
' 6. RENAMEFILE   Rename the File         true/false
' 7. BASENAME     Letter at the Front     DSC
'*************************************************
'
'*************************************************
Const StartFrom   = "P:\Photo\NEWCAM"       '==== 1.
Const CopyTo      = "P:\Photo"              '==== 2.
Const EXT_OK      = ",JPG,MPG,"             'comma then EXT then Comma  ie ,JPG,
Const LenEDI      = 7                       'Lenght of the Count String
Const Deletefile  = true                    'Delete files from the StartFrom
Const RENAMEFILE  = False                   'Rename Files
Const BASENAME    = "DSC"                   'leading Letter

'*************************************************
'
'*************************************************
Dim FileCount
Call Start_Read
'*******************************************************************
'
'
'
'*******************************************************************
Sub Start_Read()
    FileCount = 0
    Dim FSO, Folder, SubFolders, Drive
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(StartFrom)
    FileCount = FileCount + 1
    Call GenerateFolderInformation(Folder)
    Set FSO = Nothing
    MsgBox "Copy Finish copied " & FileCount & " Files to " & CopyTo
End Sub

Sub GenerateFolderInformation(Folder)
   Dim S
   Dim SubFolders
   Dim SubFolder
   Dim Files
   Dim File
   Dim FileName
   Dim FSO, EXT, TMPyear, MyMonth, TMPMonth, NewFileName
   Dim MYYear
   Set FSO = CreateObject("Scripting.FileSystemObject")
   Set Files = Folder.Files
   If Files.Count <> 0 Then
     For Each File In Files
        EXT = UCase(Right(File.Name, 3))
        If InStr(UCase(EXT_OK), "," & EXT & ",") > 0 Then
        MYYear = Year(File.DateLastModified)
        TMPyear = CopyTo & "\" & MYYear
        If Not FolderExist(TMPyear) Then CreateFolder (TMPyear)
        
        MyMonth = MonthName(Month(File.DateLastModified), True)
        TMPMonth = TMPyear & "\" & MyMonth
        If Not FolderExist(TMPMonth) Then CreateFolder (TMPMonth)
		if RENAMEFILE = true then 
        		NewFileName = TMPMonth & "\" & BaseName & "" & EDITXT(FileCount, LenEDI, "0", True) & "." & EXT
		Else
		        NewFileName = TMPMonth & "\" & File.name
		End if
	'Now Do the Work
            FSO.CopyFile File, NewFileName
            if Deletefile = true then FSO.Deletefile(file)
            FileCount = FileCount + 1
        End If
     Next
   End If
   Set SubFolders = Folder.SubFolders
    If SubFolders.Count <> 0 Then
      For Each SubFolder In SubFolders
         Call GenerateFolderInformation(SubFolder)
      Next
   End If
Set File = Nothing
Set SubFolder = Nothing
End Sub

Function EDITXT(ThisText, Leng, Txt, Leading)
    If Len(ThisText) >= Leng Then
        ThisText = Mid(ThisText, 1, Leng)
    Else
    End If
    If Leading Then
        EDITXT = String(Leng - Len(ThisText), Txt) & ThisText
    Else
        EDITXT = ThisText & String(Leng - Len(ThisText), Txt)
    End If
    If Len(EDITXT) <> Leng Then Stop
End Function

Function FolderExist(FolderName)
    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(FolderName) Then
        FolderExist = True
    Else
        FolderExist = False
    End If
End Function

Function CreateFolder(FolderName)
	Dim fs, f
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set f = fs.CreateFolder(FolderName)
	Set f = Nothing
	Set fs = Nothing
End Function

Injoy

I see the new TV have USB Plug in them now,

Why did I put rename in the script
because the wife start rename them and even they are in differance folders could have the same name twice because the my mark 1 dig frame could only handle a fileing system 2 folders deap
it put leading 0 so that the photo are Display in the rigth order. 

Please comment.....

or download this file

SortPhoto.txt (4.05 kb)

just rename to a .vbs and change the Const bit to your setting