//=============================================================================
'//Purge Sub-Folders // Säubere Unterordner
'//By Stefan, Version 2018.08.28.01
'//Found at:
https://ghisler.ch/board/viewtopic.php?p=346604#p346604
'
'//Purpose: move all files from all sub folder to start folder
'//Usage: start this script in wanted start folder (Mainfolder)
'
'//Verwendungszweck: Unterordner automatisch löschen und alle Dateien in das aktuelle Verzeichnis verschieben
'//Verwendung: Starte dieses Skript im gewünschtem Hauptordner (Mainfolder)
'VON:
'MainFolder\Ordner 2\img001.jpg
'MainFolder\Ordner 2\Sub\img001.jpg
'MainFolder\Ordner 2\img0268.jpg
'...
'
'ZU:
'MainFolder\img001.jpg
'MainFolder\img001_2.jpg
'MainFolder\img0268.jpg
'...
'
'
'//============================================================================= TC Button
' Command/Kommando: "X:\Path to\This Script.ext"
' Parameters:
' Start path/Startpfad:
' Icon: WCMICONS.DLL
' Tooltip: Purge Sub-Folders // Säubere Unterordner
'//============================================================================= SCRIPT BASICS
Set FSO = CreateObject("Scripting.FileSystemObject")
SET WSO = CreateObject("wscript.Shell")
UserTEMP = WSO.ExpandEnvironmentStrings("%tmp%")
sStartFolder = FSO.GetFolder(".")
strLogText = "" 'initialize variable for later use
iProcessedFilesCounter = 0 'count amount of precessed files
iProcessedFolderCounter= 0
'//============================================================================= USER SETTINGS
strLanguageSprache = "Deutsch" 'MsgBox Deutsch or English
iDuplicateFilesSerial = 2 'start counter for first double file name
iWantedPadding = 0 'pad iDuplicateFilesSerial with zero's (0 or 1 for NO, else 2 or more for 01,02...)
bShowDebugLog = True 'Show log at the end? (TRUE for Yes, please. FALSE for No, thanks)
bDelete_SubFolders = True 'Delete sub folders after purging?
strLogFile = UserTEMP & "\TC_PurgeFolder_" & Timestamp & ".log"
'//============================================================================= PROMPT THE USER
If (lcase(strLanguageSprache) = "deutsch") Then
str1 = "Verschiebe alle Dateien aller Unterordner des aktuellen Ordners: "
str2 = "in eben diesen aktuellen Ordner?"&vbLF&"(Doppelte Dateien werden nummeriert)"&vbLF&vbLF&"Lösche Unterordner: "&bDelete_SubFolders
str3 = "TC Unterordner aufräumen - Debug"
ELSE
str1 = "Move all files from all sub folder of the current folder: "
str2 = "up to that very current folder?"&vbLF&"(Dublicat files are numbered)"&vbLF&vbLF&"Delete sub folders: "&bDelete_SubFolders
str3 = "TC Purge Folder - Debug"
End If '//strLanguageSprache = "Deutsch"
MB = MsgBox(str1&vbLF&vbLF&sStartFolder&vbLF&vbLF&str2,vbOKCancel+vbQuestion,str3)
If (MB = vbCancel) Then WScript.Quit
'//=============================================================================
'//=============================================================================
'//============================================================================= THE CODE, DO NOT MODIFY
'//============================================================================= move files
RecurseFolders(sStartFolder)
Sub RecurseFolders(strFolder)
Set oStartFolder = FSO.GetFolder(strFolder)
For Each oFolder In oStartFolder.SubFolders
strFolderToDel = oFolder.path
'msgbox "fld " & oFolder.path
For Each oFile In oFolder.Files
iProcessedFilesCounter = iProcessedFilesCounter + 1
iSerial = iDuplicateFilesSerial
sFile = oFile.Name
If FSO.FileExists(sStartFolder & "\" & sFile) Then
sBase = FSO.GetBaseName(sFile)
sExte = FSO.GetExtensionName(sFile)
Do While FSO.FileExists(sStartFolder & "\" & sBase & "_" & Pad(iSerial,iWantedPadding) & "." & sExte)
iSerial = iSerial + 1
Loop
sFile = sBase & "_" & Pad(iSerial,iWantedPadding) & "." & sExte
iSerial = iDuplicateFilesSerial '//back to wanted start digit
End If
If (oFile.path <> "") Then
'StoreToLog oFile.path & vbTAB & sStartFolder & "\"& sFile,True
StoreToLog oFile.path ,True
End If
FSO.MoveFile oFile.path, sStartFolder & "\" & sFile
Next
RecurseFolders oFolder.Path
Next
End Sub 'RecurseFolders
StoreToLog Now() & ": " & "Moved " & iProcessedFilesCounter & " files:",False
'//============================================================================= delete sub folder
If iProcessedFilesCounter > 0 Then
strDelFldLog=""
ForEachFolder(sStartFolder)
End If
Sub ForEachFolder(strFolder)
Set oStartFolder = FSO.GetFolder(strFolder)
For Each oFolder In oStartFolder.SubFolders
iProcessedFolderCounter = iProcessedFolderCounter + 1
strDelFldLog=strDelFldLog & oFolder.path & vbCRLF
'FSO.DeleteFolder( "FullFolderPath"[,force])
FSO.DeleteFolder( oFolder.path )
Next
End Sub 'ForEachFolder
StoreToLog vbCRLF&vbCRLF,True
StoreToLog Now() & ": " & "Deleted " & iProcessedFolderCounter & " folders:",True
StoreToLog strDelFldLog,True
'//============================================================================= write log file
WriteToLog(strLogText)
'//============================================================================= finishing // show log file
If bShowDebugLog Then
If iProcessedFilesCounter > 0 Then
WSO.run "notepad.exe " & strLogFile
ELSE
MsgBox "Nothing found to move!"
End If
End If
'//============================================================================= timestamp handler
Function Timestamp
N = Now
D = Year(N) & Right("00" & Month(N), 2) & Right("00" & Day(N), 2)
T = Right("00" & Hour(N), 2) & Right("00" & Minute(N), 2) & Right("00" & Second(N), 2)
Timestamp = D & T
End Function 'Timestamp
'//============================================================================= log file handler
Sub StoreToLog(strMSG, bAppend)
If(bAppend) Then
strLogText = strLogText & strMSG & vbCRLF
ELSE
strLogText = strMSG & vbCRLF & strLogText
End IF
End Sub 'StoreToLog(strMSG, bAppend)
Sub WriteToLog(strMSG)
Const ForAppending = 8
Set FileOut = FSO.OpenTextFile(strLogFile,ForAppending,True)
FileOut.Write(strMSG)
FileOut.Close
End Sub 'WriteToLog(msg)
'//=============================================================================
Function Pad(iINT, iWantLen)
If(iWantLen = 0) Then iWantLen = 1
Pad = String( iWantLen-Len(iINT),"0") & iINT
End Function
'//=============================================================================
'//============================================================================= THIS IS THE END FRIEND