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
