我正在尝试创建重命名脚本。表中会有一组数据。
例如
OldName NewName Folder
\\...\ABC\123.pdf X000001 ABC
\\...\ABC\124.pdf X000002 ABC
\\...\XYZ\199.pdf X000075 XYZ
我只想逐个文件夹重命名。所以在脚本运行之前会有输入框。
我知道如何手动重命名文件
Name OldName As NewName
如何为目录中的每个文件创建一个循环 - 值形式 InputBox 并用相应的 NewName 重命名它们？
【问题讨论】：
标签： ms-access foreach vba rename
一旦我创建了批量移动/重命名 Excel 辅助实用程序。下面的代码可以是一个合适的例子：
' 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
只需将其保存为.vbs 文件，然后按照标题中的说明进行操作即可。最后，VBScript 代码只需稍作改动即可在 VBA 环境中使用。
【讨论】：