Verzeichnisse und Dateien netzwerkkonform umbenennen (Programmierung / Office/VBasic / vb.net / vbs / wsh)

Wir müssen sämtliche Dateien und Verzeichnisse unserer Netzwerkablage so umbenennen, das die keine Umlaute und Sonderzeichen mehr enthalten. Habe dafür ein Tool geschrieben, aber es klappt nicht richtig!

Was korrekt läuft, ist die korrektur der unerlaubten Zeichen. Ich habe also den gewünschten String des neuen Dateinamens. Jetzt wollte ich mit der NAME Funktion die Dateien umbenennen. Das funktioniert aber nur teilweise. Unterverzeichnisse berücksichtigt er nicht. Und alle Dateien, die in einem Verzeichnis liegen, das Sonderzeichen enthält, werden auch nicht geändert. Nicht zu vergessen natürlich, das er das Verzeichnis ansich auch nicht umbenennt.
Leider kann ich die VBA Datei nich anhängen, deshalb tue ich den Code mal hier rein.

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long

Private z!

'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function

Sub Dateisuche(Laufwerk, Dateien)
Dim tmp, Wdhlg, Dateiname As String
Dim KorName As String
On Error Resume Next
If Right(Laufwerk, 1) <> "\" Then Laufwerk = Laufwerk + "\"

tmp = Dir(Laufwerk & Dateien)

Do While Len(tmp)
Dateiname = Laufwerk & tmp
Application.StatusBar = Dateiname
Cells(z, 1).Select
Cells(z, 1) = Laufwerk & tmp 'Pfad
'Cells(z, 2) = FileLen(Laufwerk & tmp) 'Größe
'Cells(z, 3) = FileDateTime(Laufwerk & tmp) 'Datum/Zeit
'Cells(z, 4) = tmp 'nur Dateiname

KorName = KorrekterDateiname(Dateiname)
Cells(z, 2) = KorName

If Dateiname <> KorName Then Name Dateiname As KorName

z = z + 1
tmp = Dir()
Loop
tmp = Dir(Laufwerk, vbDirectory)
Do While Len(tmp)
If (tmp <> ".") And (tmp <> "..") Then
If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche Laufwerk & tmp, Dateien
z = z - 1
Wdhlg = Dir(Laufwerk, vbDirectory)
z = z + 1
Do While Wdhlg <> tmp
Wdhlg = Dir()
Loop
End If
End If
tmp = Dir()
Loop
On Error GoTo 0
Application.StatusBar = False
End Sub

'Aufruf mit dem folgenden Makro
Sub Suchen()
Dim Laufwerk$, Dateien$
'Ersze Zeile, in der eine Eintragung erfolgt
z = 2
'Alte Eintragungen löschen
[a1:e5000] = ""
'Den Variablen Laufwerk und Dateien kann
'auch ein direkter Wert zugewiesen werden.
'Ersatz: ... = "C:\Eigene Dateien"
Laufwerk = GetDirectory("Bitte einen Ordner wählen")
If Laufwerk = "" Then Exit Sub
'Ersatz: Dateien = "*.*"
Dateien = InputBox("Nach welchen Dateien soll in" & _
Chr(10) & " " & Laufwerk & Chr(10) & _
"gesucht werden (z. B. *.xls)?", _
"Dateityp", "*.*")
If Dateien = "" Then Exit Sub
Dateisuche Laufwerk, Dateien
End Sub

Private Function KorrekterDateiname(DateinameAlt As String) As String
Dim DateinameNeu As String
Dim BuchstabeAlt As String
Dim BuchstabeNeu As String
Dim Laufwerksbuchstabe As String
Dim DateiEndung As String
Dim i As Integer

Laufwerksbuchstabe = Left(DateinameAlt, 2)
DateiEndung = Right(DateinameAlt, 4)
For i = 1 To Len(DateinameAlt) - 4
BuchstabeAlt = Mid(DateinameAlt, i, 1)
With Sheets("Einstellungen")
Select Case BuchstabeAlt:
Case .Cells(2, 1).Value
BuchstabeNeu = .Cells(2, 2).Value
Case .Cells(3, 1).Value
BuchstabeNeu = .Cells(3, 2).Value
Case .Cells(4, 1).Value
BuchstabeNeu = .Cells(4, 2).Value
Case .Cells(5, 1).Value
BuchstabeNeu = .Cells(5, 2).Value
Case .Cells(6, 1).Value
BuchstabeNeu = .Cells(6, 2).Value
Case .Cells(7, 1).Value
BuchstabeNeu = .Cells(7, 2).Value
Case .Cells(8, 1).Value
BuchstabeNeu = .Cells(8, 2).Value
Case .Cells(9, 1).Value
BuchstabeNeu = .Cells(9, 2).Value
Case .Cells(10, 1).Value
BuchstabeNeu = .Cells(10, 2).Value
Case .Cells(11, 1).Value
BuchstabeNeu = .Cells(11, 2).Value
Case .Cells(12, 1).Value
BuchstabeNeu = .Cells(12, 2).Value
Case .Cells(13, 1).Value
BuchstabeNeu = .Cells(13, 2).Value
Case .Cells(14, 1).Value
BuchstabeNeu = .Cells(14, 2).Value
Case .Cells(15, 1).Value
BuchstabeNeu = .Cells(15, 2).Value
Case .Cells(16, 1).Value
BuchstabeNeu = .Cells(16, 2).Value
Case .Cells(17, 1).Value
BuchstabeNeu = .Cells(17, 2).Value
Case .Cells(18, 1).Value
BuchstabeNeu = .Cells(18, 2).Value
Case .Cells(19, 1).Value
BuchstabeNeu = .Cells(19, 2).Value
Case .Cells(20, 1).Value
BuchstabeNeu = .Cells(20, 2).Value
Case .Cells(21, 1).Value
BuchstabeNeu = .Cells(21, 2).Value
Case .Cells(22, 1).Value
BuchstabeNeu = .Cells(22, 2).Value
Case .Cells(23, 1).Value
BuchstabeNeu = .Cells(23, 2).Value
Case " "
BuchstabeNeu = .Cells(24, 2).Value
Case Else
BuchstabeNeu = BuchstabeAlt
End Select
End With
DateinameNeu = DateinameNeu + BuchstabeNeu
Next i
KorrekterDateiname = DateinameNeu + DateiEndung
End Function

------------------
Grüßle
Gregi

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP