AW: Kürzen von Dateinamen
07.05.2005 19:10:59
Dateinamen
Hallo
Probier mal das:
Option Explicit
Sub Rename_Files()
Dim tmpName As String, tarName As String, tarPath As String
Dim myFSO As Object, myFld As Object, myFldFiles As Object, myFile As Object
Dim docCounter As Integer, xlsCounter As Integer, renCounter As Integer
Dim i As Integer, fileCount As Integer
Dim myErr As Integer
On Error GoTo myErrorHandler
'Erstellen des FileSystemObjectes
Set myFSO = CreateObject("Scripting.FileSystemObject")
tarPath = InputBox("Bitte Verzeichnis angeben, indem die Daten umebeannt werden sollen", "Rename Action", "C:\DemoVerz")
If Not myFSO.folderexists(tarPath) Then
MsgBox "Der Ordner :"" " & tarPath & " "" existiert nicht.", vbCritical + vbOKOnly, "Abbruch"
Exit Sub
End If
docCounter = 0
xlsCounter = 0
renCounter = 0
myErr = 1
'Name schleife starten
Set myFld = myFSO.GetFolder(tarPath)
Set myFldFiles = myFld.Files
'Tage ab wann gelöscht werden soll
For Each myFile In myFldFiles
tmpName = myFile.Name
If Right(tmpName, 3) = "doc" Then
tarName = Left(tmpName, 8) & ".doc"
ElseIf Right(tmpName, 3) = "xls" Then
tarName = Left(tmpName, 8) & ".xls"
End If
NameRestart:
myFile.Name = tarName
renCounter = renCounter + 1
Next
MsgBox "Es wurden " & renCounter & " Dateien umbenannt"
'Fehlerbehandlung Ende
myErrorExit:
Exit Sub
'Fehlerbehandlung starten
myErrorHandler:
Select Case Err
Case 58
If Right(tmpName, 3) = "doc" Then
tarName = Left(tarName, 7) & docCounter & ".doc"
docCounter = docCounter + 1
ElseIf Right(tmpName, 3) = "xls" Then
tarName = Left(tarName, 7) & xlsCounter & ".xls"
xlsCounter = xlsCounter + 1
End If
Resume NameRestart
Case Else
MsgBox Err.Number & ": " & Err.Description, vbCritical + vbOKOnly, "Unerwarteter Fehler > Abbruch Rename Action"
Resume myErrorExit
End Select
End Sub
Gruss Rainer