Option Explicit
Const ForWriting = 2
Const scstrSource="C:\Users\seakintruth\Pictures"
Const scstrDestination="C:\Users\seakintruth\Videos\Home Videos"
Dim strContent
Main
Public Sub Main()
Dim fs:Set fs = CreateObject("Scripting.FileSystemObject")
Dim fldr:set fldr = fs.GetFolder( scstrSource)
strContent = "Path,Name,Size" & vbcrlf
Search(fldr)
If len(strContent) > 0 then
Dim fMovieList
Set fMovieList = fs.OpenTextFile(GetEnvironmentVar("userprofile") & "\Desktop\logMovieList.csv", ForWriting,True)
fMovieList.WriteLine strContent
End If
End Sub
Public Function Search(fldr)
Dim strSearchPath:strSearchPath=fldr.path
Dim fs:Set fs = CreateObject("Scripting.FileSystemObject")
Dim subfldrs:Set subfldrs = fldr.SubFolders
Dim fil
Dim strFileName
Dim subfldr
Dim strCurrentFolderName
Dim strCurrentExtension
Dim strDestination
For each subfldr in subfldrs
For each fil in subfldr.Files
strCurrentExtension = Lcase(fs.GetExtensionName(fil.name))
Select Case strCurrentExtension
'Video file extension list
Case "aaf","3gp","gif","asf","avchd","avi","cam","dat","dsh","flv","m1v","m2v","fla","flr","sol","m4v","mkv", _
"wrap","mng","mov","mpeg","mpg","mpe","mp4","mxf","roq","nsv","ogg","rm","svi","smi","swf","wmv"
strContent = strContent & subfldr.path & "," & fil.name & "," & fil.size & vbcrlf
'The following errors can be removed when i build a function to rebuild the destination path based on the number of "\"s
on error resume next
If Len(subfldr.path) - Len(scstrSource) > 0 then
strDestination = scstrDestination & Right(subfldr.path, Len(subfldr.path) - Len(scstrSource))
Else
strDestination = scstrDestination
End If
strFileName = fil.Name
If not fs.FolderExists(scstrDestination & Right(strSearchPath, Len(strSearchPath) - Len(scstrSource))) then
fs.CreateFolder(scstrDestination & Right(strSearchPath, Len(strSearchPath) - Len(scstrSource)))
End If
If not fs.FolderExists(strDestination) then
fs.CreateFolder(strDestination)
End If
fil.Move strDestination & "\" & strFileName
on error goto 0
End select
Next
Search(subfldr)
Next
End Function
Public Function GetEnvironmentVar(strEnvironmentVariable)
Dim oShell:Set oShell = CreateObject( "WScript.Shell" )
GetEnvironmentVar=oShell.ExpandEnvironmentStrings("%" & strEnvironmentVariable & "%")
End Function
==========================================================================================================================
Same idea with more options, and a little error handling
==========================================================================================================================
Option Explicit
'Robocopy will do all of this and more,
'this is mostly just example code I wrote
'to remind myself how to recursively search
'through folders and modify files programmatically
'Jeremy Gerdes
'Input
'Source and destination folders must already exist
Const scstrScriptName = "Remove Useless Paths"
Const fRemoveCustomFolders= True
Const fRemoveEmptyDirectories = True
'Need to be variables as they can be changed by the WriteToLog Sub
Dim fLogFoldersFound: fLogFoldersFound = True
Dim fLogFilesFound: fLogFilesFound=True
Const scstrCustomFoldersToRemove=".picasaoriginals,.SyncArchive" 'List of folder names seperated by ,'s (Commas)
Const scstrCustomFilesToRemove="Thumbs.db,.picasa.ini,View Online.url,Feed.rss,desktop.ini"'List of file names seperated by ,'s (Commas)
Const scstrMovieDestinationFolderName="Videos"
Const fProcessFileTypes = False
Const fMoveFiles=False
Const fCopyFiles=False
'End of user input Will make all of these ini values
Dim fCancel
Dim fError
Dim scstrDestination
Dim scstrLogDestination
Dim scstrSource
Dim filLog
Const ForWriting = 2
Const ForAppending = 8
'Building the arrays publicly then we don't have to split it every time that we look at the arrays latter
Dim astrCustomFoldersToRemove:astrCustomFoldersToRemove = Split(scstrCustomFoldersToRemove,",")
Dim astrCustomFilesToRemove:astrCustomFilesToRemove = split(scstrCustomFilesToRemove,",")
Main
Public Sub Main()
'Optionally use relative path code for source
Dim objShell
Dim fs
Dim Folder
scstrDestination = GetEnvironmentVar("Userprofile")
Set objShell = WScript.CreateObject("Shell.Application")
Dim strScriptFullName
strScriptFullName = Wscript.ScriptFullName
scstrSource = Left(strScriptFullName , InStrRev(strScriptFullName , "\", -1, 0)-1)
Set fs = CreateObject("Scripting.FileSystemObject")
set Folder = fs.GetFolder(scstrSource)
scstrLogDestination = scstrSource & "\" & scstrScriptName & ".csv"
If fLogFilesFound or fLogFoldersFound then
WriteToLog """Path"",""Name"",""Size"",""Descriptive Size"",""File Extention"",""Is Folder"",""Additional Comments""", ForWriting
End If
If Not fCancel Then
Search Folder
End If
If fError Then
Msgbox scstrScriptName & "Completed with errors"
Else
Msgbox scstrScriptName & "Complete"
End If
'Cleanup
filLog.Close
Set objShell = Nothing
Set Folder = Nothing
Set fs = Nothing
End Sub
Public Function Search(Folder)
If Not fCancel Then
Dim fs:Set fs = CreateObject("Scripting.FileSystemObject")
'Dig through sub folders first(recursively)
Dim subFolders:Set subFolders = Folder.SubFolders
Dim subFolder
For each subFolder in subFolders
On error resume next
Search(subFolder)
If err.number <> 0 then
strFolderInfo=SetCsv(Folder.path) & "\" & SetCsv(subFolder.name) & "," & SetCsv(subFolder.name) & ",,,,,Error: Unable to process folder likely an access issue"
WriteToLog strFileInfo & SetCsv(strContent),ForAppending
End If
Next
'Process Folder First
Dim strCurrentFolderName
Dim strDestination
Dim strContent: strContent=Null
Dim dblFolderSize
Dim fDeleteFolder
Dim strFolderInfo
Dim strSearchFolderPath
'Resset the delete folder flag
fDeleteFolder = False
'Get folder info prior to deleting folder if required
strSearchFolderPath = Folder.path
dblFolderSize = Folder.size
strFolderInfo=SetCsv(Folder.path) & "," & SetCsv(Folder.name) & "," & SetCsv(dblFolderSize) & "," & SetCsv(strGetDescriptiveDataSize(dblFolderSize)) & ","""",""" & True & ""","
'-Delete Custom Folders
Dim intCustomFoldersCount 'astrCustomFilesToRemove
For intCustomFoldersCount=0 to Ubound(astrCustomFoldersToRemove)
If Folder.Name = astrCustomFoldersToRemove(intCustomFoldersCount) Then
If fLogFoldersFound Then
strContent = strContent & "Folder To Be Deleted - Custom:" & astrCustomFoldersToRemove(intCustomFoldersCount)
End if
If fRemoveCustomFolders then
fDeleteFolder = True
End if
End if
Next
'Process Files after custom folders have been flagged for deletion
If fs.FolderExists(strSearchFolderPath) And Not fCancel And Not fDeleteFolder Then
Dim fil
Dim strFileName
Dim dblFileSize
Dim strFileInfo
Dim strCurrentExtension
For each fil in Folder.Files
strCurrentExtension = Lcase(fs.GetExtensionName(fil.name))
'Gather file info prior to performing any action
dblFileSize = fil.size
strFileInfo = SetCsv(fil.path) & "," & SetCsv(fil.name) & "," & SetCsv(dblFileSize) & "," & SetCsv(strGetDescriptiveDataSize(dblFileSize)) & "," & SetCsv(strCurrentExtension) & ",""" & False & ""","
Dim intCustomFilesCount
strContent = Null
For intCustomFilesCount=0 to Ubound(astrCustomFilesToRemove)
If fil.name = astrCustomFilesToRemove(intCustomFilesCount) then
err.clear
on error resume next
fil.Delete True
If err.number <> 0 then
strContent = strContent & "An error occurred attempting to delete this file"
Else
strContent = strContent & "File deleted"
Exit For
End if
err.clear
on error goto 0
End if
Next
If fProcessFileTypes And fs.FileExists(fil.path) then
Select Case strCurrentExtension
'Video file extension list found on Wikipedia :)
Case "aaf","3gp","gif","asf","avchd","avi","cam","dat","dsh","flv", _
"m1v","m2v","fla","flr","sol","m4v","mkv","wrap","mng","mov", _
"mpeg","mpg","mpe","mp4","mxf","roq","nsv","ogg","rm","svi", _
"smi","swf","wmv"
If fLogFilesFound then
strContent = strContent & "Found A Video File"
End if
If fMoveFiles Or fCopyFiles then
'Build Destination Directory
strDestination = scstrDestination & "\" & scstrMovieDestinationFolderName
BuildDestinationPath(strDestination)
End If
strFileName = fil.Name
If fCopyFiles then
fil.Copy strDestination & "\" & strFileName
End if
If fMoveFiles then
fil.Move strDestination & "\" & strFileName
End if
Case Else
End select
End if
If fLogFilesFound then
WriteToLog strFileInfo & SetCsv(strContent),ForAppending
If fCancel Then
Exit For
End If
End if
Next
End If
'-Delete folder if empty
If Folder.SubFolders.count = 0 And Folder.Files.count = 0 Then
If fLogFoldersFound Then
strContent = strContent & "Empty Folder To Be Deleted "
End If
If fRemoveEmptyDirectories Then
fDeleteFolder = True
End if
End if
'-Delete Folder
If fDeleteFolder And Not fCancel Then
On Error Resume Next
err.clear
Folder.Delete True
If err.number <> 0 Then
strContent = strContent & "*Folder Deleted*"
Else
strContent = strContent & "*An Error occurred during deletion attempt*"
End if
Err.Clear
On error goto 0
End If
If fLogFoldersFound then
WriteToLog strFolderInfo & SetCsv(strContent), ForAppending
End if
'Cleanup
Set subFolders = Nothing
Set fs = Nothing
Set fil = Nothing'
End If
End Function
Function SetCsv(srtContent)
SetCsv = """" & srtContent & """"
End Function
Function strGetDescriptiveDataSize(FileSize) 'optional lngPrecision = 2, optional fShortDescription = True)
Const lngPrecision = 2
Const fShortDescription = True
'See https://en.wikipedia.org/wiki/File_size
'B,KB,MB,GB,TB,PB,EB,ZB,YB,BB
'KiloByte,MegaByte,GigaByte,TeraByte,PetaByte,ExaByte,ZettaByte,YottaByte,Brontobyte,Geopbyte
Dim astrDescription
Dim strDataSizes
Dim strContent
Dim intCount
If fShortDescription Then
strDataSizes = "B,KB,MB,GB,TB,PB,EB,ZB,YB,BB"
Else
strDataSizes = "Bytes,KiloBytes,MegaBytes,GigaBytes,TeraBytes,PetaBytes,ExaBytes,ZettaBytes,YottaBytes,Brontobytes,Geopbytes"
End If
astrDescription = Split(strDataSizes, ",")
Dim dblFileSize
dblFileSize = CDbl(FileSize)
Select Case True
Case dblFileSize < (2 ^ 10)
strContent = dblFileSize & " " & astrDescription(0) 'No rounding required at the byte level
Case dblFileSize < (2 ^ 20)
strContent = Round(dblFileSize / 2 ^ 10, lngPrecision) & " " & astrDescription(1)
Case dblFileSize < (2 ^ 30)
strContent = Round(dblFileSize / 2 ^ 20, lngPrecision) & " " & astrDescription(2)
Case dblFileSize < (2 ^ 40)
strContent = Round(dblFileSize / 2 ^ 30, lngPrecision) & " " & astrDescription(3)
Case dblFileSize < (2 ^ 50)
strContent = Round(dblFileSize / 2 ^ 40, lngPrecision) & " " & astrDescription(4)
Case dblFileSize < (2 ^ 60)
strContent = Round(dblFileSize / 2 ^ 50, lngPrecision) & " " & astrDescription(5)
Case dblFileSize < (2 ^ 70)
strContent = Round(dblFileSize / 2 ^ 60, lngPrecision) & " " & astrDescription(6)
Case dblFileSize < (2 ^ 80)
strContent = Round(dblFileSize / 2 ^ 70, lngPrecision) & " " & astrDescription(7)
Case dblFileSize < (2 ^ 90)
strContent = Round(dblFileSize / 2 ^ 80, lngPrecision) & " " & astrDescription(8)
Case dblFileSize < (2 ^ 100)
strContent = Round(dblFileSize / 2 ^ 90, lngPrecision) & " " & astrDescription(9)
Case Else
strContent = dblFileSize & " " & astrDescription(0) 'Else report in bytes
End Select
strGetDescriptiveDataSize = strContent
End Function
Sub WriteToLog(strLine, lngAccess)
Dim fs:Set fs = CreateObject("Scripting.FileSystemObject")
Dim fExitLoop
fExitLoop = False
On Error Resume Next
Do
err.clear
If lngAccess = ForWriting Then
Set filLog = fs.OpenTextFile(scstrLogDestination, lngAccess,True)
End If
filLog.WriteLine strLine
'filLog.Close
If err.number <> 0 Then
Select Case Msgbox ("The log file may be locked or you don't have permission to create the file" & vbcrlf & "If you can close the file do so and click Yes to try again, or click No to resume without logging or click Cancel to exit this script.",vbYesNoCancel )
Case vbCancel
fCancel = True
fError = True
fExitLoop = True
Case vbNo
fLogFilesFound = False
fLogFoldersFound = False
fError = True
fExitLoop = True
Case vbYes
'Do nothing as another attempt will be made.
Case Else
fCancel = True
fError = True
fExitLoop = True
End select
End if
Loop Until (fExitLoop Or Err.Number = 0)
err.clear
on error goto 0
'Clean up
Set fs = Nothing
End Sub
Sub BuildDestinationPath(strDestination)
Dim fs:Set fs = CreateObject("Scripting.FileSystemObject")
Dim astrFolders
Dim strFolderPath
Dim strCurrentFolderPath
Dim strCurrentFolderRight
Dim intCurrentFolder
astrFolders=Split(Right(strDestination,Len(strDestination)-Len(scstrDestination)),"\")
For intCurrentFolder = 0 To Ubound(astrFolders)
strCurrentFolderRight = strCurrentFolderRight & astrFolders(intCurrentFolder) & "\"
strCurrentFolderPath = scstrDestination & strCurrentFolderRight
If not fs.FolderExists(strCurrentFolderPath) Then
fs.CreateFolder(strCurrentFolderPath)
End If
Next
'Cleanup
Set fs = Nothing
End Sub
Function GetEnvironmentVar(strEnvironmentVariable)
Dim objShell: Set objShell = CreateObject( "WScript.Shell" )
GetEnvironmentVar=objShell.ExpandEnvironmentStrings("%" & strEnvironmentVariable & "%")
'Cleanup
Set objShell= Nothing
End Function