batch_move_rename_excel_assisted_utility.vbs

' Batch move / rename Excel assisted utility.

' The code below is batch move / rename utility. Select files or / and folders in explorer folder or in explorer search results to be renamed / moved and drag onto this script file. Files in subfolders will be included.

' Then source files foldername, filename and extension populates the first 3 columns of created Excel worksheet, and the same values in the next 3 columns for destination files. After making necessary changes to destination columns, confirm in first dialog to start batch. If destination folder(s) doesn't exists - it will be created. All changes can be rolled back by selecting Cancel in second dialog.

' As you know Excel has powerfull tools for text processing, now what you need for batch move / rename is just to replace text in certain cells. Experienced who knows Excel inside out can do that easily. E. g. select entire row with filenames or foldernames, press Ctrl+H and replace some text in all cells. Or enter name with number to the first cell and stretch it  across others to auto-numerate. Therefore few clicks allows to change all filenames and even move files to another folders.

Option Explicit
Const xlWBATWorksheet = -4167
Dim oFSO, oChgFiles, oChgFolders, oApp, oWB, oWS,  aFiles(), aCells(), aTask, lRow, sSrc, sDst, sStat, sCmt, sKey, bNotDeleted

If WScript.Arguments.Count = 0 then
    CreateObject("WScript.Shell").PopUp "Drag'n'Drop files to batch move / rename", 3, "Batch move / rename", vbInformation
    WScript.Quit
End If

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oChgFiles = CreateObject("Scripting.Dictionary")
Set oChgFolders = CreateObject("Scripting.Dictionary")
Set oApp = CreateObject("Excel.Application")
oApp.Visible = True
Set oWB = oApp.Workbooks.Add(xlWBATWorksheet)
Set oWS = oWB.Worksheets(1)
Redim aFiles(-1)
For Each sSrc In WScript.Arguments
    AddFiles sSrc
Next
If UBound(aFiles) = -1 Then
    CreateObject("WScript.Shell").PopUp "No files selected", 3, "Batch move / rename", vbInformation
    WScript.Quit
End If
ReDim aCells(UBound(aFiles), 5)
For lRow = 0 To UBound(aFiles)
    aCells(lRow, 0) = oFSO.GetParentFolderName(aFiles(lRow))
    aCells(lRow, 1) = oFSO.GetBaseName(aFiles(lRow))
    aCells(lRow, 2) = oFSO.GetExtensionName(aFiles(lRow))
    aCells(lRow, 3) = oFSO.GetParentFolderName(aFiles(lRow))
    aCells(lRow, 4) = oFSO.GetBaseName(aFiles(lRow))
    aCells(lRow, 5) = oFSO.GetExtensionName(aFiles(lRow))
Next
oWS.Range(oWS.Cells(1, 1), oWS.Cells(UBound(aFiles) + 1, 6)).NumberFormat = "@"
oWS.Range(oWS.Cells(1, 1), oWS.Cells(UBound(aFiles) + 1, 6)).Value = aCells
oWS.Columns.AutoFit
oWB.Saved = True

If MsgBox("Columns contains:" & vbCrLf & vbCrLf & "Source files:" & vbCrLf & "A - path" & vbCrLf & "B - name" & vbCrLf & "C - ext" & vbCrLf & vbCrLf & "Destination files:" & vbCrLf & "D - path" & vbCrLf & "E - name" & vbCrLf & "F - ext" & vbCrLf & vbCrLf & "Make changes to destination then press OK to batch move / rename", vbOKCancel + vbInformation, "Batch move / rename") = vbOK Then
    sStat = ""
    If ChkWb Then
        aTask = oWS.Range(oWS.Cells(1, 1), oWS.Cells(UBound(aFiles) + 1, 6)).Value
        For lRow = 1 To UBound(aTask) ' used src
            Do ' do loop block used to provide skip the rest with exit do
                If Not ChkWb Then Exit Do
                On Error Resume Next
                If Right(aTask(lRow, 1), 1) <> "\" Then aTask(lRow, 1) = aTask(lRow, 1) & "\"
                sSrc = aTask(lRow, 1) & aTask(lRow, 2)
                If aTask(lRow, 3) <> "" Then
                    sSrc = sSrc & "." & aTask(lRow, 3)
                End If
                If Not oFSO.FileExists(sSrc) Then
                    sCmt = "Source file doesn't exists"
                    Exit Do
                End If
                If Right(aTask(lRow, 4), 1) <> "\" Then aTask(lRow, 4) = aTask(lRow, 4) & "\"
                sDst = aTask(lRow, 4) & aTask(lRow, 5)
                If aTask(lRow, 6) <> "" Then
                    sDst = sDst & "." & aTask(lRow, 6)
                End If
                If Not ChkWb Then Exit Do
                If LCase(sSrc) = LCase(sDst) Then
                    sCmt = "Source and destination the same"
                    Exit Do
                End If
                sCmt = ""
                If oChgFiles.Exists(sDst) Then
                    sCmt = "Another destination file with same name has been processed already" ' interrupt if another dst with same name has been processed already
                    Exit Do
                End If
                If oFSO.FileExists(sDst) Then ' dst file already exists - need dst backup
                    If oFSO.FileExists(sDst & ".DSTBAK") Then ' old dst backup already exists - need to delete
                        oFSO.DeleteFile sDst & ".DSTBAK", True ' delete old dst backup
                        If IsError("Del prev .DSTBAK", sCmt) Then Exit Do
                    End If
                    oFSO.MoveFile sDst, sDst & ".DSTBAK" ' make dst backup
                    If IsError("Move DST -> .DSTBAK", sCmt) Then Exit Do
                    oChgFiles.Add sDst & ".DSTBAK", sDst ' add data for dst backup to be recovered while rollback actions
                Else ' dst file hasn't exist yet - not need dst backup
                    ' файла dst нет - здесь нужно проверить наличие папки dst и создать если ее нет, после проверить оибку
                    If Not oFSO.FolderExists(oFSO.GetParentFolderName(sDst)) Then ' dst folder hasn't exist yet - need to create
                        SmartCreateFolder oFSO.GetParentFolderName(sDst) ' create dst folder
                        If IsError("Create DST folder", sCmt) Then Exit Do ' interrupt if error creating dst folder
                    End If
                    oChgFiles.Add sDst, "" ' add data for dst to be deleted while rollback actions
                End If
                oFSO.CopyFile sSrc, sDst, True ' copy src to dst
                If IsError("Copy SRC -> DST", sCmt) Then Exit Do
                If oFSO.FileExists(sSrc & ".SRCBAK") Then ' old src backup already exists - need to delete
                    oFSO.DeleteFile sSrc & ".SRCBAK", True ' delete old src backup
                    If IsError("Del prev .SRCBAK", sCmt) Then Exit Do
                End If
                oFSO.MoveFile sSrc, sSrc & ".SRCBAK" ' make src backup
                If IsError("Move SRC -> .SRCBAK", sCmt) Then Exit Do
                oChgFiles.Add sSrc & ".SRCBAK", sSrc ' add data for src backup to be recovered while rollback actions
                If Err.Number <> 0 Then Err.Clear
            Loop Until True ' no repeat
            On Error Goto 0
            If sCmt <> "" Then
                AddMsg sSrc & vbCrLf & sCmt, sStat
                On Error Resume Next
                Do
                    Err.Clear
                    oWS.Activate
                    If oWS.Cells(lRow, 1).Comment Is Nothing Then oWS.Cells(lRow, 1).AddComment
                    oWS.Cells(lRow, 1).Comment.Visible = False
                    oWS.Cells(lRow, 1).Comment.Text sCmt
                    oWB.Saved = True
                Loop While (Err.Number <> 0) And ChkWb
            End If
        Next
        If Not ChkWb Then AddMsg "Batch interrupted due to Excel workbook closed", sStat
        If sStat <> "" Then ShowInNotepad sStat ' show batch errors
        On Error Resume Next
        If oChgFiles.Count > 0 Or oChgFolders.Count > 0 Then
            sStat = ""
            If MsgBox("OK - confirm changes, Cancel - rollback", vbOKCancel + vbQuestion, "Batch move / rename") = vbOK Then
                If MsgBox("Remove all backup files?", vbOKCancel + vbQuestion, "Batch move / rename") = vbOK Then
                    For Each sKey In oChgFiles
                        If oChgFiles(sKey) <> "" Then
                            oFSO.DeleteFile sKey, True
                            IsError "Delete" & vbCrLf & sKey, sStat
                        End If
                    Next
                End If
            Else
                For Each sKey In oChgFiles
                    If oChgFiles(sKey) = "" Then
                        oFSO.DeleteFile sKey, True
                        IsError "Delete" & vbCrLf & sKey, sStat
                    Else
                        If oFSO.FileExists(oChgFiles(sKey)) Then
                            oFSO.DeleteFile oChgFiles(sKey), True
                            IsError "Delete" & vbCrLf & oChgFiles(sKey), sStat
                        End If
                        oFSO.MoveFile sKey, oChgFiles(sKey)
                        IsError sKey & vbCrLf & "Move To" & vbCrLf & oChgFiles(sKey), sStat
                    End If
                Next
                Do
                    bNotDeleted = True
                    For Each sKey In oChgFolders ' each created folder
                        If oFSO.FolderExists(sKey) Then
                            With oFSO.GetFolder(sKey)
                                If (.Files.Count = 0) And (.SubFolders.Count = 0) Then
                                    .Delete True
                                    If Not IsError("Delete" & vbCrLf & sKey, sStat) Then bNotDeleted = False
                                End If
                            End With
                        End If
                    Next
                Loop Until bNotDeleted ' untill no changes pass
            End If
            On Error Goto 0
            If sStat <> "" Then ShowInNotepad sStat ' show rollback errors
        Else
            CreateObject("WScript.Shell").PopUp "No changes made", 3, "Batch move / rename", vbInformation
            On Error Goto 0
        End If
    End If
End if
If ChkWb Then
    oWB.Saved = True
    If CreateObject("WScript.Shell").PopUp("Close Excel?", 3, "Batch move / rename", vbOKCancel + vbQuestion) <> vbCancel Then oApp.Quit
End If

Function ChkWb
    ChkWb = (TypeName(oWB) <> "Object")
End Function

Sub AddFiles(sPath)
    Dim oItem
    If oFSO.FileExists(sPath) Then
        AddFile sPath
        Exit Sub
    End If
    If oFSO.FolderExists(sPath) Then
        For Each oItem In oFSO.GetFolder(sPath).Files
            AddFile oItem.Path
        Next
        For Each oItem In oFSO.GetFolder(sPath).SubFolders
            AddFiles oItem.Path
        Next

    End If
End Sub

Sub AddFile(sPath)
    Redim Preserve aFiles(UBound(aFiles) + 1)
    aFiles(UBound(aFiles)) = sPath
End Sub

Function IsError(sMsg, sRes)
    If Err.Number <> 0 Then
        AddMsg sMsg & vbCrLf & "Error " & Err.Number & ", " & Err.Description, sRes
        IsError = True
        Err.Clear
    Else
        IsError = False
    End If
End Function

Sub AddMsg(sMsg, sRes)
    If sRes <> "" Then sRes = sRes & vbCrLf & vbCrLf
    sRes = sRes & sMsg & vbCrLf
End Sub

Sub ShowInNotepad(strToFile)
    Dim strTempPath
    With oFSO
        strTempPath = CreateObject("WScript.Shell").ExpandEnvironmentStrings("%TEMP%") & "\" & .GetTempName
        With .CreateTextFile(strTempPath, True, True)
            .WriteLine("Close this window to continue" & vbCrLf & vbCrLf & vbCrLf & strToFile)
            .Close
        End With
        CreateObject("WScript.Shell").Run "notepad.exe " & strTempPath, 1, True
        .DeleteFile (strTempPath)
    End With
End Sub

Sub SmartCreateFolder(strFolder)
    ' http://www.visualbasicscript.com/tm.aspx?m=29290
    With oFSO
        If Not .FolderExists(strFolder) then
            SmartCreateFolder(.GetParentFolderName(strFolder))
            .CreateFolder(strFolder)
            If Not oChgFolders.Exists(strFolder) Then
                oChgFolders.Add strFolder, "" ' add data for created dst folder to be deleted while rollback actions
            End If
        End If
    End With
End Sub