VBS MoveFileType

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

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