Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1168to1172
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

alle Dateien in einem Ordner umbenennen

alle Dateien in einem Ordner umbenennen
Joachim
Hallo,
ich hab in einem Ordner ca. 400 pdf-Files. Diese muss ich jetzt umbenennen. Die Dateinamen beginnen immer gleich, erst 7 Zeichen, dann eine 14-stellige Nummer, dann der Rest, der aber unterschiedlich lang sein kann. Ich muss nun aus der 14-stelligen Nummer eine 15-stellige machen, sprich nach der 12. Stelle noch eine 0 einfügen.
Was ich so im Forum gefunden habe, ging immer mit einer Tabelle, in der die Dateinamen stehen (Spalte A alter Name, Spalte B neuer Name). Diese Tabelle hab ich aber nicht. Geht das auch ohne - oder wie bekomm ich die Dateinamen in eine Tabelle?
Gruss
Joachim
AW: alle Dateien in einem Ordner umbenennen
02.08.2010 11:07:41
Tino
Hallo,
versuch mal so.
Bitte zuerst nur testen!
kommt als Code in Modul1
Option Explicit 
 
Sub Start() 
Dim ArrayFiles(), lngCounter& 
Dim strPath$, sNew_Name$ 
 
strPath = fncGetFolder 
If strPath = "" Then Exit Sub 
 
Call ListFilesInFolder(ArrayFiles, strPath, "*.pdf", False, lngCounter) 
 
If lngCounter > 0 Then 
    For lngCounter = Lbound(ArrayFiles) To Ubound(ArrayFiles) 
        sNew_Name$ = Left$(ArrayFiles(lngCounter), InStrRev(ArrayFiles(lngCounter), ".") - 1) 
        sNew_Name = sNew_Name & "0.pdf" 
        Name ArrayFiles(lngCounter) As sNew_Name 
    Next lngCounter 
End If 
 
 
End Sub 
kommt als Code in Modul2
Option Explicit 
 
'Listet Files in Area 
Sub ListFilesInFolder(FileArray, SourceFolderName As String, Optional DateiFormat As String = "*.*", _
                        Optional IncludeSubfolders As Boolean = False, Optional LCount As Long = 0) 
 
Dim FSO As Object, SourceFolder As Object, SubFolder As Object 
Dim FileItem 
Dim Status As Integer 
  
 Set FSO = CreateObject("Scripting.FileSystemObject") 
  
 If FSO.FolderExists(SourceFolderName) Then 
     Set SourceFolder = FSO.GetFolder(SourceFolderName) 
             
        On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein 
          
        For Each FileItem In SourceFolder.Files 
            If LCase(FileItem) Like LCase(DateiFormat) Then 
             Redim Preserve FileArray(LCount) 
             FileArray(LCount) = FileItem 
             LCount = LCount + 1 
            End If 
        Next FileItem 
     
     
        If IncludeSubfolders Then 
            For Each SubFolder In SourceFolder.SubFolders 
                ListFilesInFolder FileArray, SubFolder.Path, DateiFormat, IncludeSubfolders, LCount 
            Next SubFolder 
        End If 
 Else 
       MsgBox "Ordner nicht gefunden!", vbCritical 
 End If 
 
Err_Zugriff: 
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing 
End Sub 
 
kommt als Code in Modul3
Option Explicit 
 
Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long 
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long 
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long 
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long 
 
Private Type InfoT 
    hwnd As Long 
    Root As Long 
    DisplayName As Long 
    Title As Long 
    Flags As Long 
    FName As Long 
    lParam As Long 
    Image As Long 
End Type 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Private s_BrowseInitDir As String 
Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long 
    If uMsg = &H1 Then 
        Call SendMessage(hwnd, &H466, ByVal 1&, ByVal s_BrowseInitDir) 
        Call CenterDialog(hwnd) 
    End If 
    BrowseCallback = 0 
End Function 
 
Private Function FuncCallback(ByVal nParam As Long) As Long 
    FuncCallback = nParam 
End Function 
 
Private Sub CenterDialog(ByVal hwnd As Long) 
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer 
    Dim DlgWidth As Integer, DlgHeight As Integer 
    GetWindowRect hwnd, WinRect 
    DlgWidth = WinRect.Right - WinRect.Left 
    DlgHeight = WinRect.Bottom - WinRect.Top 
    ScrWidth = GetSystemMetrics(&H10) 
    ScrHeight = GetSystemMetrics(&H11) 
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1 
End Sub 
 
Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal sPath As String = "C:\") As String 
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String 
     
    If sPath Like "*.?" Or sPath Like "*.?" Then 
     sPath = Left$(sPath, InStrRev(sPath, "\")) 
    End If 
    
    If Dir(sPath, vbDirectory) = "" Then 
        sPath = ThisWorkbook.Path 
    End If 
     
    s_BrowseInitDir = sPath 
    With xl 
        .hwnd = FindWindow("XLMAIN", vbNullString) 
        .Root = 0 
        .Title = lstrcat(sMsg, "") 
        .Flags = &H1 
        .FName = FuncCallback(AddressOf BrowseCallback) 
    End With 
    IDList = SHBrowseForFolder(xl) 
    If IDList <> 0 Then 
        FolderName = Space(256) 
        RVal = SHGetPathFromIDList(IDList, FolderName) 
        CoTaskMemFree (IDList) 
        FolderName = Trim$(FolderName) 
        FolderName = Left$(FolderName, Len(FolderName) - 1) 
    End If 
    fncGetFolder = FolderName 
End Function 
 
Gruß Tino
Anzeige
AW: alle Dateien in einem Ordner umbenennen
02.08.2010 12:26:24
Joachim
Hallo Tino,
dein Programm fügt am Ende des Dateinamens eine 0 ein. Ich brauch sie aber zwischen der 19. und 20. Stelle von links.
Gruss
Joachim
AW: alle Dateien in einem Ordner umbenennen
02.08.2010 12:38:00
Rudi
Hallo,
auch wenn das für mich nach mit Kanonen auf Spatzen schießen aussieht ...
Sub Start()
Dim ArrayFiles(), lngCounter&
Dim strPath$, sNew_Name$
strPath = fncGetFolder
If strPath = "" Then Exit Sub
Call ListFilesInFolder(ArrayFiles, strPath, "*.pdf", False, lngCounter)
If lngCounter > 0 Then
For lngCounter = LBound(ArrayFiles) To UBound(ArrayFiles)
sNew_Name = Left$(ArrayFiles(lngCounter), 19) & "0" & Mid(ArrayFiles(lngCounter), 20)
Name ArrayFiles(lngCounter) As sNew_Name
Next lngCounter
End If
End Sub

Anzeige
AW: alle Dateien in einem Ordner umbenennen
02.08.2010 12:47:39
Joachim
Hallo Rudi,
ich dachte nicht, dass das so ausartet.
Bei deinem Code kommt ne Fehlermeldung: Datei nicht gefunden
Gruss
Joachim
versuche es mit dieser Version...
02.08.2010 13:39:34
Tino
Hallo,
kommt als Code in Modul1
Option Explicit 
 
Sub Start() 
Dim ArrayFiles(), lngCounter& 
Dim strPath$, sNew_Name$ 
 
Const lngPos As Long = 19 
 
strPath = fncGetFolder 
If strPath = "" Then Exit Sub 
 
Call ListFilesInFolder(ArrayFiles, strPath, "*.pdf", False, lngCounter) 
 
strPath = IIf(Right$(strPath, 1) = "\", strPath, strPath & "\") 
If lngCounter > 0 Then 
    For lngCounter = Lbound(ArrayFiles, 2) To Ubound(ArrayFiles, 2) 
        If Len(ArrayFiles(1, lngCounter)) - 4 >= lngPos Then 
            sNew_Name$ = Mid(ArrayFiles(1, lngCounter), 1, lngPos) 
            sNew_Name$ = sNew_Name$ & "0" & Mid(ArrayFiles(1, lngCounter), lngPos + 1, Len(ArrayFiles(1, lngCounter))) 
            Name ArrayFiles(0, lngCounter) As strPath & sNew_Name 
        End If 
    Next lngCounter 
End If 
 
 
End Sub 
kommt als Code in Modul2
Option Explicit 
 
'Listet Files in Area 
Sub ListFilesInFolder(FileArray, SourceFolderName As String, Optional DateiFormat As String = "*.*", _
                        Optional IncludeSubfolders As Boolean = False, Optional LCount As Long = 0) 
 
Dim FSO As Object, SourceFolder As Object, SubFolder As Object 
Dim FileItem 
Dim Status As Integer 
  
 Set FSO = CreateObject("Scripting.FileSystemObject") 
  
 If FSO.FolderExists(SourceFolderName) Then 
     Set SourceFolder = FSO.GetFolder(SourceFolderName) 
             
        On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein 
          
        For Each FileItem In SourceFolder.Files 
            If LCase(FileItem) Like LCase(DateiFormat) Then 
             Redim Preserve FileArray(1, LCount) 
             FileArray(0, LCount) = FileItem 
             FileArray(1, LCount) = FileItem.Name 
             LCount = LCount + 1 
            End If 
        Next FileItem 
     
     
        If IncludeSubfolders Then 
            For Each SubFolder In SourceFolder.SubFolders 
                ListFilesInFolder FileArray, SubFolder.Path, DateiFormat, IncludeSubfolders, LCount 
            Next SubFolder 
        End If 
 Else 
       MsgBox "Ordner nicht gefunden!", vbCritical 
 End If 
 
Err_Zugriff: 
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing 
End Sub 
 
kommt als Code in Modul3
Option Explicit 
 
Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long 
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long 
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long 
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    lpbi As InfoT) As Long 
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long 
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long 
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long 
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal Msg As Long, _
    wParam As Any, _
    lParam As Any) As Long 
 
Private Type InfoT 
    hwnd As Long 
    Root As Long 
    DisplayName As Long 
    Title As Long 
    Flags As Long 
    FName As Long 
    lParam As Long 
    Image As Long 
End Type 
 
Private Type RECT 
    Left As Long 
    Top As Long 
    Right As Long 
    Bottom As Long 
End Type 
 
Private s_BrowseInitDir As String 
Private Function BrowseCallback( _
        ByVal hwnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long 
    If uMsg = &H1 Then 
        Call SendMessage(hwnd, &H466, ByVal 1&, ByVal s_BrowseInitDir) 
        Call CenterDialog(hwnd) 
    End If 
    BrowseCallback = 0 
End Function 
 
Private Function FuncCallback(ByVal nParam As Long) As Long 
    FuncCallback = nParam 
End Function 
 
Private Sub CenterDialog(ByVal hwnd As Long) 
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer 
    Dim DlgWidth As Integer, DlgHeight As Integer 
    GetWindowRect hwnd, WinRect 
    DlgWidth = WinRect.Right - WinRect.Left 
    DlgHeight = WinRect.Bottom - WinRect.Top 
    ScrWidth = GetSystemMetrics(&H10) 
    ScrHeight = GetSystemMetrics(&H11) 
    MoveWindow hwnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1 
End Sub 
 
Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal sPath As String = "C:\") As String 
    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String 
     
    If sPath Like "*.?" Or sPath Like "*.?" Then 
     sPath = Left$(sPath, InStrRev(sPath, "\")) 
    End If 
    
    If Dir(sPath, vbDirectory) = "" Then 
        sPath = ThisWorkbook.Path 
    End If 
     
    s_BrowseInitDir = sPath 
    With xl 
        .hwnd = FindWindow("XLMAIN", vbNullString) 
        .Root = 0 
        .Title = lstrcat(sMsg, "") 
        .Flags = &H1 
        .FName = FuncCallback(AddressOf BrowseCallback) 
    End With 
    IDList = SHBrowseForFolder(xl) 
    If IDList <> 0 Then 
        FolderName = Space(256) 
        RVal = SHGetPathFromIDList(IDList, FolderName) 
        CoTaskMemFree (IDList) 
        FolderName = Trim$(FolderName) 
        FolderName = Left$(FolderName, Len(FolderName) - 1) 
    End If 
    fncGetFolder = FolderName 
End Function 
 
Gruß Tino
Anzeige
AW: versuche es mit dieser Version...
02.08.2010 13:49:31
Joachim
Hallo Tino,
Juhu, jetzt geht es!!
Dachte nicht, dass das sooo aufwendig ist.
Vielen Dank!!
Gruss
Joachim
AW: versuche es mit dieser Version...
02.08.2010 14:17:18
Tino
Hallo,
das aufwendige ist ja nur der Dialog für die Ordnerauswahl.
Wenn Du den Pfad fest vergibst, ist der Code um einigen kleiner.
Auch die Suchfunktion könnte man mit einer Dir() Schleife kürzer halten.
Kürzer ist aber nicht immer besser,
mit der Dir Funktion habe ich auch schon schlechte Erfahrung gemacht, dass einfach nichts gefunden wird.
Sub Start()
Dim ArrayFiles(), lngCounter&
Dim strPath$, sNew_Name$

Const lngPos As Long = 19

strPath = "G:\1 Forum\Test Ordner"

If strPath = "" Then Exit Sub
strPath = IIf(Right$(strPath, 1) = "\", strPath, strPath & "\")

Call ListFilesInFolder(ArrayFiles, strPath, "*.pdf", lngCounter)


If lngCounter > 0 Then
    For lngCounter = Lbound(ArrayFiles, 2) To Ubound(ArrayFiles, 2)
        If Len(ArrayFiles(1, lngCounter)) - 4 >= lngPos Then
            sNew_Name$ = Mid(ArrayFiles(1, lngCounter), 1, lngPos)
            sNew_Name$ = sNew_Name$ & "0" & Mid(ArrayFiles(1, lngCounter), lngPos + 1, Len(ArrayFiles(1, lngCounter)))
            Name ArrayFiles(0, lngCounter) As strPath & sNew_Name
        End If
    Next lngCounter
End If

End Sub


Sub ListFilesInFolder(FileArray, sPath$, Optional DateiFormat$ = "*.*", Optional LCount As Long = 0)
Dim strFile$
 
strFile$ = Dir(sPath & DateiFormat, vbNormal)
 
Do While strFile <> ""
    Redim Preserve FileArray(1, LCount)
    FileArray(0, LCount) = sPath & strFile
    FileArray(1, LCount) = strFile
    LCount = LCount + 1
    strFile = Dir
Loop

End Sub
Gruß Tino
Anzeige
Dialog für die Ordnerauswahl
02.08.2010 14:26:38
Anton
Hallo Tino,
bei mir funktioniert sowas:
Code:

Sub ordnerauswahl()
  Dim BrowseDir As Object  
  Set BrowseDir = CreateObject("Shell.Application").BrowseForFolder(0, "Ordner auswählen", &H0, 17)    
  If Not BrowseDir Is Nothing Then    
    MsgBox BrowseDir.self.Path
  End If  
  Set BrowseDir = Nothing  
End Sub  


mfg Anton
Anzeige
auch nicht schlecht, kannte ich nicht oT.
02.08.2010 14:46:34
Tino
wie kannst Du einen Ordner vorgeben?
02.08.2010 15:04:38
Tino
Hallo,
ist es möglich bei Deiner Version einen Ordner vorzugeben?
Gruß Timo
wie kannst Du einen Ordner vorgeben?
02.08.2010 15:14:12
Anton
Hallo Tino,
Set BrowseDir = CreateObject("Shell.Application").BrowseForFolder(0, "Ordner auswählen", &H0, "E:\Temp")
Problem dabei ist , das du nur in diesem Ordner bewegen kannst.
Hier kleine Beschreibung.
mfg Anton
ok. danke oT.
02.08.2010 15:42:55
Tino
und mit msoFileDialogFolderPicker ?
02.08.2010 16:10:03
Yal
Hi,
habe folgendes aus meiner Fundgrube entstaubt:
Public Function VerzeichnisName_auswählen(StartPfad$) As String
'Mit Verweis auf
'Microsoft Office 11.0 obejct Library
'C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.InitialFileName = StartPfad
If fd.Show Then
VerzeichnisName_auswählen = fd.SelectedItems(1)
End If
End Function
kann aber nicht sagen, ob es nach Office 2003 noch funktioniert.
Yal
Anzeige
AW: alle Dateien in einem Ordner umbenennen
02.08.2010 12:41:33
JogyB
Hallo Joachim,
lad Dir die Demoversion von TotalCommander bei www.ghisler.com herunter, der hat ein Mehrfach-Umbenenn-Tool (gibt auch noch andere Freeware-Programme für sowas). Für sowas extra ein Excel-Makro zu schreiben ist völlig unnötig.
Bei Total Commander müsstest Du (wenn Du alles richtig beschrieben hast) unter Name
[N1-19]0[20-]
eintragen. Teste das aber erstmal mit einer Kopie des Verzeichnisses.
Gruß, Jogy
Anzeige
Fehler
02.08.2010 12:42:22
JogyB
Hallo,
wäre [N1-19]0[N20-]
Gruß, Jogy
AW: alle Dateien eines Ordners - mit VBA
02.08.2010 14:11:43
Yal
Hallo zusammen,
wenn es doch mit VBA gehen soll, ohne dass es kompliziert wird, einfach die FileSearch zusammen mit einem FSO verwenden.
Sub Dateien_umbenennen()
Const cPfad = "C:\MeinVerzeichnis\"
Dim i As Integer
'folgende Variablen mit Verweis auf
'Microsoft Scripting RunTime - C:\WINDOWS\system32\scrrun.dll
Dim fs As New FileSystemObject
Dim f As File
With Application.FileSearch
.LookIn = cPfad
.Filename = "*.pdf"
.Execute
For i = 1 To .FoundFiles.Count
Set f = fs.GetFile(.FoundFiles(i))
f.Name = Mid(f.Name, 1, 19) & "0" & Mid(f.Name, 20)
Next i
End With
End Sub

Selbstverständlich zuerst testen.
Viel Erfolg
Yal
Anzeige
da würde ich aber dazu schreiben, ...
02.08.2010 14:21:24
Tino
Hallo,
dass dies nur bis xl2003 funktioniert.
Gruß Tino
...wenn ich gewusst hätte!
02.08.2010 14:25:49
Yal
@Tino: interessent. Ein Glück, dass bei dem Antragsteller der Fall ist.
Was funktioniert danach nicht mehr? (mein etwa langsam reagierende Arbeitsgeber wechselt doch irgenwann auf 2007er) Wohl nicht den FSO, sondern eher den FileSearch, nehmen ich an?
Yal
FileSearch ist das Problem
02.08.2010 14:41:42
Tino
Hallo,
das bei Versionswechsel >2003 die Makros auf einmal nicht mehr gehen.
Gruß Tino
FileSearch für 2003 aufWärts
02.08.2010 15:19:54
Yal
Da es nicht mehr funktionieren soll, suchen wir sofort für Ersatz.
In folgende Beitrag wird eine eigene Klasse clsFileSearch aufgebaut. Diese kann auch in PERSONL.XLS eingebaut werden.
http://www.office-loesung.de/ftopic148247_0_0_asc.php
Yal
Anzeige
alternativen gibt es genug. oT.
02.08.2010 15:45:58
Tino

304 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige