Files - Rename!

With the following code all file extensions of the files in a folder are renamed. In this example from "*.csv" to "*.txt". Subfolders can be considered optionally. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1, Module2, Module3".


Mit folgendem Code werden alle Dateiendungen der Dateien in einem Ordner umbenannt. In diesem Beispiel von "*.csv" nach "*.txt". Unterordner können optional berücksichtigt werden. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1, Modul2, Modul3".


Option Explicit
Const strOldEX As String = ".csv"
Const strNewEX As String = ".txt"
Public Sub Files_Rename()
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(ThisWorkbook.Path & "\")
'Call dirInfo(objDir, "*" & strOldEX, True) ' with subfolders
Call dirInfo(objDir, "*" & strOldEX)
Fin:
Set objDir = Nothing
Set objFSO = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim strNewName As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If UCase(varTMP.Name) Like UCase(strName) Then
strNewName = Replace(varTMP.Name, strOldEX, strNewEX)
Name varTMP.Path As varTMP.ParentFolder & "\" & strNewName
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
End Sub


Option Explicit
Dim strOldEX As String
Dim strNewEX As String
Public Sub Files_Rename_1()
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
strOldEX = InputBox("OLD extension e.g. csv", "Rename", "csv")
If strOldEX = "" Then Exit Sub
If Right(strOldEX, 1) <> "." Then strOldEX = "." & strOldEX
strNewEX = InputBox("NEW extension e.g. txt", "Rename", "txt")
If strNewEX = "" Then Exit Sub
If Right(strNewEX, 1) <> "." Then strNewEX = "." & strNewEX
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(ThisWorkbook.Path & "\")
'Call dirInfo(objDir, "*" & strOldEX, True) ' with subfolders
Call dirInfo(objDir, "*" & strOldEX)
Fin:
Set objDir = Nothing
Set objFSO = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim strNewName As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If UCase(varTMP.Name) Like UCase(strName) Then
strNewName = Replace(varTMP.Name, strOldEX, strNewEX)
Name varTMP.Path As varTMP.ParentFolder & "\" & strNewName
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
End Sub


Option Explicit
Public intTMP As Integer
Dim strOldEX As String
Dim strNewEX As String
Public Sub Files_Rename_2()
Dim objFSO As Object
Dim objDir As Object
On Error GoTo Fin
strOldEX = InputBox("OLD extension e.g. csv", "Rename", "csv")
If strOldEX = "" Then Exit Sub
If Left(strOldEX, 1) <> "." Then strOldEX = "." & strOldEX
strNewEX = InputBox("NEW extension e.g. txt", "Rename", "txt")
If strNewEX = "" Then Exit Sub
If Left(strNewEX, 1) <> "." Then strNewEX = "." & strNewEX
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objDir = objFSO.GetFolder(funcDirectory("C:\"))
'Call dirInfo(objDir, "*" & strOldEX, True) ' with subfolders
Call dirInfo(objDir, "*" & strOldEX)
Fin:
If intTMP = 0 Then
MsgBox "No files renamed!"
Else
MsgBox intTMP & " files renamed!"
intTMP = 0
End If
Set objDir = Nothing
Set objFSO = Nothing
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Sub dirInfo(ByVal objCurrentDir As Object, ByVal strName As String, _
Optional ByVal blnTMP As Boolean = False)
Dim strNewName As String
Dim varTMP As Variant
For Each varTMP In objCurrentDir.Files
If UCase(varTMP.Name) Like UCase(strName) Then
strNewName = Replace(varTMP.Name, strOldEX, strNewEX)
intTMP = intTMP + 1
Name varTMP.Path As varTMP.ParentFolder & "\" & strNewName
End If
Next varTMP
If blnTMP = True Then
For Each varTMP In objCurrentDir.SubFolders
dirInfo varTMP, strName, True
Next varTMP
End If
End Sub
Private Function funcDirectory(strFolder As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Folder"
.ButtonName = "Select..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strFolder = .SelectedItems(1)
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
Else
strFolder = ""
End If
End With
funcDirectory = strFolder
End Function


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...