STORZ NEUROLITH TPS Problem and Solution

Here is the Source Code for VBA 2003, download it and put it into grok or gemini and add the picture above, the AI will tell you exactly how to rebuild it in ACCESS – otherwise reach out to me or to SOZO Braincenter in Nicosia to get the Program

Option Compare Database
Option Explicit

Private Sub Befehl10_Click()

End Sub

Private Sub bCopyFiles_Click()
Call CopyMRTDir(Me.ePatVerezcinis, Me.eUSB)
End Sub

Private Sub bCorrectFN_Click()
‘ Rename auf kopiertem Ordner aufrufen
Dim renameResult As String
If Nz(Me.eUSB) = “” Then
MsgBox “no USB-Dongle Path”
Exit Sub
End If
renameResult = RenameDICOMFilesToStandard(Me.eUSB)
SysCmd acSysCmdClearStatus
MsgBox “Rename abgeschlossen ” + renameResult
End Sub

Private Sub bDirNameCorrect_Click()
Call StartRenameDonglePathProcess(Me.eUSB)
End Sub

Private Sub bEraseDICOMDIR_Click()
Call DeleteFile(Fullpath(Me.eUSB) + “DICOMDIR”)
End Sub

Private Sub bPatVerzeichnis_Click()
Dim s As String
s = BrowseForFolder2(Nz(Me.eMRT_Default))
Me.ePatVerezcinis = s
End Sub

Private Sub bTomoVision_Click()
Call StartDICOMDir
End Sub

Private Sub bUSBDir_Click()
Dim s As String
s = BrowseForFolder2(“”)
Me.eUSB = s
End Sub

Function Fullpath(Path As String) As String
‘ Fügt einen Backslash am Ende eines Pfads hinzu, falls nicht vorhanden.
‘ Rückgabe: Pfad mit abschließendem Backslash.

If Right(Path, 1) <> “\” Then
Fullpath = Path & “\”
Else
Fullpath = Path
End If
End Function

Function DeleteFile(FilePath As String) As String
‘ Löscht die übergebene Datei.
‘ Rückgabe: “Erfolg” oder Fehlermeldung.

On Error GoTo ErrorHandler

Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)

If fso.FileExists(FilePath) Then
fso.DeleteFile FilePath
DeleteFile = “Datei ” & FilePath & ” erfolgreich gelöscht.”
Else
DeleteFile = “Fehler: Datei ” & FilePath & ” nicht gefunden.”
End If

Exit Function

ErrorHandler:
DeleteFile = “Fehler: ” & err.Description
End Function

Option Compare Database
Option Explicit

Function RenameDICOMFilesToStandard(FolderPath As String) As String
‘ Umbenennt alle Dateien rekursiv in Ordner und Unterordnern zu standardkonformen DICOM-Namen (IMnnnnnn.DCM).
‘ Zeigt Fortschritt in Statusleiste, kein Log für Originalnamen.
‘ Rückgabe: “Erfolg” oder Fehlermeldung.

On Error GoTo ErrorHandler

Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)

‘Call RenameSubFoldersRecursive(FolderPath)

‘ Zähle Gesamtanzahl Dateien rekursiv
Dim TotalFiles As Long
TotalFiles = CountFilesRecursive(FolderPath)
If TotalFiles = 0 Then
RenameDICOMFilesToStandard = “Keine Dateien zum Umbenennen.”
Exit Function
End If

‘ Rekursives Umbenennen starten
Dim Processed As Long ‘ Wird in RenameRecursive aktualisiert
Processed = 0
Call RenameRecursive(FolderPath, TotalFiles, Processed)

SysCmd acSysCmdClearStatus
RenameDICOMFilesToStandard = “Dateien umbenannt (” & TotalFiles & ” Dateien).”
Beep
Exit Function

ErrorHandler:
SysCmd acSysCmdClearStatus
RenameDICOMFilesToStandard = “Fehler: ” & err.Description
End Function

Private Function CountFilesRecursive(SourcePath As String) As Long
‘ Zählt Dateien rekursiv in Ordner und Unterordnern
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim folder As Object
Set folder = fso.GetFolder(SourcePath)
CountFilesRecursive = folder.files.Count
Dim subFolder As Object
For Each subFolder In folder.SubFolders
CountFilesRecursive = CountFilesRecursive + CountFilesRecursive(subFolder.Path)
Next
End Function

Private Sub RenameRecursive(CurrentPath As String, TotalFiles As Long, ByRef Processed As Long)
‘ Rekursives Umbenennen von Dateien, aktualisiert Processed und Fortschritt
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim folder As Object
Set folder = fso.GetFolder(CurrentPath)

‘ Rekursion in Unterordner
Dim subFolder As Object
For Each subFolder In folder.SubFolders
RenameRecursive subFolder.Path, TotalFiles, Processed
Next

‘ Dateien in aktuellem Ordner umbenennen
Dim file As Object
Dim i As Long
i = 1 ‘ Lokaler Zähler pro Ordner; globaler i könnte angepasst werden, falls einzigartige Namen benötigt
For Each file In folder.files
Dim NewName As String
NewName = “IM” & Format(i, “0000”) ‘ & “.DCM”
file.Name = NewName
i = i + 1
Processed = Processed + 1

‘ Fortschritt alle 20 Dateien aktualisieren
If Processed Mod 20 = 0 Or Processed = TotalFiles Then
Call UpdateProgressBar(Processed / TotalFiles)
End If
Next
End Sub

Private Sub UpdateProgressBar(Progress As Single)
‘ Erstellt Balken-String und setzt Status
Dim barLength As Integer
barLength = 24 ‘ Gesamtlänge des Balkens
Dim filled As Integer
filled = Int(Progress * barLength)
Dim bar As String
bar = String(filled, “|”) & String(barLength – filled, ” “) & “|”
SysCmd acSysCmdSetStatus, “Fortschritt: ‘” & bar & “‘ (” & Format(Progress, “0%”) & “)”
End Sub

Function CopyMRTDir(DefaultSourcePath As String, Optional DestinationPath As String = “G:\”) As String
‘ Kopiert Ordner rekursiv auf USB, zeigt Fortschritt, ruft dann Rename auf.
‘ Rückgabe: “Erfolg” oder Fehlermeldung.

On Error GoTo ErrorHandler

‘ Ordner-Dialog öffnen (mit Default als Start)
Dim sourceFolder As String
sourceFolder = BrowseForFolder2(DefaultSourcePath)
If sourceFolder = “” Then
CopyMRTDir = “Abbruch: Kein Ordner ausgewählt.”
Exit Function
End If

‘ Basename des Quellordners als Default für InputBox
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim defaultName As String
defaultName = fso.GetBaseName(sourceFolder)

‘ InputBox für Zielnamen
Dim targetName As String
targetName = InputBox(“Geben Sie den Namen für den Zielordner ein:”, “Zielordnername”, defaultName)
If targetName = “” Then
CopyMRTDir = “Abbruch: Kein Name angegeben.”
Exit Function
End If

Dim targetFolder As String
targetFolder = DestinationPath & targetName & “\”

‘ Zielordner erstellen, falls nicht existent
If Not fso.FolderExists(targetFolder) Then
fso.CreateFolder targetFolder
End If

‘ Gesamtanzahl Dateien zählen (rekursiv)
Dim TotalFiles As Long
TotalFiles = CountFilesRecursive(sourceFolder)
If TotalFiles = 0 Then
CopyMRTDir = “Keine Dateien zum Kopieren.”
Exit Function
End If

‘ Rekursives Kopieren mit Fortschritt
Call CopyFolderWithProgress(sourceFolder, targetFolder, TotalFiles)

‘ Rename auf kopiertem Ordner aufrufen
‘Dim renameResult As String
‘renameResult = RenameDICOMFilesToStandard(targetFolder)

SysCmd acSysCmdClearStatus
CopyMRTDir = “Kopie abgeschlossen”

Exit Function

ErrorHandler:
SysCmd acSysCmdClearStatus
CopyMRTDir = “Fehler: ” & err.Description
End Function

Function BrowseForFolder2(Optional StartPath As String = “D:\MR-CT\”) As String
‘ Ordner-Dialog in Access 2003 (Shell.Application)
‘ Startet am angegebenen StartPath, falls gültig.
Dim shellApp As Object
Dim s As Variant
s = StartPath
Set shellApp = CreateObject(“Shell.Application”)
Dim folder As Object
Set folder = shellApp.BrowseForFolder(0, “Wählen Sie den Quellordner aus”, 80, s)
If Not folder Is Nothing Then
BrowseForFolder2 = folder.self.Path
Else
BrowseForFolder2 = “”
End If
End Function

Private Function CountFilesRecursive2(SourcePath As String) As Long
‘ Zählt Dateien rekursiv
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim folder As Object
Set folder = fso.GetFolder(SourcePath)
CountFilesRecursive2 = folder.files.Count
Dim subFolder As Object
For Each subFolder In folder.SubFolders
CountFilesRecursive2 = CountFilesRecursive2 + CountFilesRecursive2(subFolder.Path)
Next
End Function

Private Sub CopyFolderWithProgress(SourcePath As String, TargetPath As String, TotalFiles As Long)
‘ Kopiert rekursiv mit Fortschritt
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim folder As Object
Set folder = fso.GetFolder(SourcePath)

‘ Unterordner erstellen und rekursiv kopieren
Dim subFolder As Object
For Each subFolder In folder.SubFolders
Dim subTarget As String
subTarget = TargetPath & subFolder.Name & “\”
If Not fso.FolderExists(subTarget) Then
fso.CreateFolder subTarget
End If
CopyFolderWithProgress subFolder.Path, subTarget, TotalFiles
Next

‘ Dateien kopieren und Fortschritt tracken
Dim file As Object
Static Processed As Long ‘ Static für globalen Zähler
For Each file In folder.files
fso.CopyFile file.Path, TargetPath & file.Name
Processed = Processed + 1
DoEvents
DoEvents
‘ Fortschritt alle 20 Dateien aktualisieren
If Processed Mod 20 = 0 Or Processed = TotalFiles Then
Call UpdateProgressBar(Processed / TotalFiles)
DoEvents
End If
Next
End Sub

Function StartDICOMDir() As String
‘ Startet C:\Program Files\TomoVision\DICOM_Dir.exe als eigenständiges Programm.
‘ Rückgabe: “Erfolg” oder Fehlermeldung.

On Error GoTo ErrorHandler

Dim exePath As String
exePath = “C:\Program Files\TomoVision\DICOM_Dir.exe”

‘ Prüfe, ob die EXE existiert
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
If Not fso.FileExists(exePath) Then
StartDICOMDir = “Fehler: DICOM_Dir.exe nicht gefunden unter ” & exePath
Exit Function
End If

‘ Starte das Programm
Shell exePath, vbNormalFocus ‘ vbNormalFocus öffnet es sichtbar

StartDICOMDir = “DICOM_Dir.exe erfolgreich gestartet.”

Exit Function

ErrorHandler:
StartDICOMDir = “Fehler: ” & err.Description
End Function

‘ Haupt-Sub zum Starten des Prozesses
Function StartRenameDonglePathProcess(Dongle As String)
If MsgBox(“Sind Sie sicher, dass Sie ALLE Verzeichnisse auf ‘” & Dongle & “‘ umbenennen möchten? Dies kann zu Datenverlust führen, wenn der Dongle in Benutzung ist oder keine Backups existieren!”, vbYesNo + vbExclamation, “WARNUNG: Verzeichnisumbenennung”) = vbYes Then
Call RenameAllDirsOnDongle(Dongle)
MsgBox “Der Umbenennungsprozess wurde abgeschlossen. Überprüfen Sie bitte den Dongle ‘” & Dongle & “‘ auf eventuelle Fehler in den Debug.Print-Ausgaben.”, vbInformation
Else
MsgBox “Der Umbenennungsprozess wurde abgebrochen.”, vbInformation
End If
End Function

Function RenameFoldersRecursive_2(RootPath As String) As String
‘ Umbenennt Ordner und alle Unterordner rekursiv zu DICOM-kompatiblen Namen.
‘ Rückgabe: “Erfolg” oder Fehlermeldung.

On Error GoTo ErrorHandler

Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)

If Not fso.FolderExists(RootPath) Then
RenameFoldersRecursive_2 = “Fehler: Root-Pfad existiert nicht.”
Exit Function
End If

‘ Starte Rekursion (ohne Root umzubenennen)
Call RenameSubFoldersRecursive(RootPath)

RenameFoldersRecursive_2 = “Ordner rekursiv umbenannt.”

Exit Function

ErrorHandler:
RenameFoldersRecursive_2 = “Fehler: ” & err.Description
End Function

Private Sub RenameSubFoldersRecursive(CurrentPath As String)
‘ Hilfsprozedur für rekursives Umbenennen von Unterordnern.
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim folder As Object
Set folder = fso.GetFolder(CurrentPath)

‘ Rekursion in Unterordner zuerst (Post-Order)
Dim subFolder As Object
For Each subFolder In folder.SubFolders
RenameSubFoldersRecursive subFolder.Path
Next

‘ Aktuellen Ordner umbenennen (nach Unterordnern)
Dim parentPath As String
parentPath = fso.GetParentFolderName(CurrentPath)
If parentPath <> “” Then ‘ Root nicht umbenennen
Dim oldName As String
oldName = fso.GetBaseName(CurrentPath)
Dim NewName As String
NewName = MakeDICOMCompatibleDirName(oldName)

If LCase(NewName) <> LCase(oldName) Or NewName <> oldName Then
Dim NewPath As String
NewPath = parentPath & “” & NewName

If fso.FolderExists(NewPath) Then
‘ Konflikt: Füge Zähler hinzu (z. B. 1)
Dim counter As Integer
counter = 1
Do While fso.FolderExists(NewPath & “” & counter)
counter = counter + 1
Loop
NewPath = NewPath & “_” & counter
End If

‘ Spezieller Fall: Wenn nur Case-Unterschied, temporären Namen verwenden
If LCase(NewName) = LCase(oldName) And NewName <> oldName Then
Dim tempPath As String
tempPath = parentPath & “\TEMP_” & Format(Now, “hhmmss”)
fso.MoveFolder CurrentPath, tempPath
fso.MoveFolder tempPath, NewPath
Else
fso.MoveFolder CurrentPath, NewPath
End If
End If
End If
End Sub

Private Sub RenameSubFoldersRecursive_buggy(CurrentPath As String)
‘ Hilfsprozedur für rekursives Umbenennen von Unterordnern.
Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim folder As Object
Set folder = fso.GetFolder(CurrentPath)

‘ Rekursion in Unterordner zuerst (Post-Order)
Dim subFolder As Object
For Each subFolder In folder.SubFolders
RenameSubFoldersRecursive (subFolder.Path)
Next

‘ Aktuellen Ordner umbenennen (nach Unterordnern)
Dim parentPath As String
parentPath = fso.GetParentFolderName(CurrentPath)
If parentPath <> “” Then ‘ Root nicht umbenennen
Dim oldName As String
oldName = fso.GetBaseName(CurrentPath)
Dim NewName As String
NewName = MakeDICOMCompatibleDirName(oldName)

If NewName <> oldName Then
Dim NewPath As String
NewPath = parentPath & “\” & NewName
If Not fso.FolderExists(NewPath) Then
fso.MoveFolder CurrentPath, NewPath
Else
‘ Konflikt: Füge Zähler hinzu (z. B. _1)
Dim counter As Integer
counter = 1
Do While fso.FolderExists(NewPath & “_” & counter)
counter = counter + 1
Loop
fso.MoveFolder CurrentPath, NewPath & “_” & counter
End If
End If
End If
End Sub

‘ Die Funktion zur Generierung DICOM-kompatibler Namen (mit Umlautbehandlung)
Function MakeDICOMCompatibleDirName(ByVal OriginalName As String) As String
Dim CleanedName As String
Dim i As Long
Dim Char As String

‘ 1. Umlaute in erweiterte ASCII-Zeichen umwandeln (Option 1 – bevorzugt)
CleanedName = replace(OriginalName, “Ä”, “AE”)
CleanedName = replace(CleanedName, “Ö”, “OE”)
CleanedName = replace(CleanedName, “Ü”, “UE”)
CleanedName = replace(CleanedName, “ä”, “AE”)
CleanedName = replace(CleanedName, “ö”, “OE”)
CleanedName = replace(CleanedName, “ü”, “UE”)
CleanedName = replace(CleanedName, “ß”, “SS”)

‘ 2. In Großbuchstaben umwandeln
CleanedName = UCase(CleanedName)

‘ 3. Ungültige Zeichen entfernen und durch Unterstriche ersetzen
For i = 1 To Len(CleanedName)
Char = Mid(CleanedName, i, 1)
If Not (Char >= “A” And Char <= “Z”) And Not (Char >= “0” And Char <= “9”) And Char <> “_” Then
Mid(CleanedName, i, 1) = “_”
End If
Next i

‘ 4. Mehrere aufeinanderfolgende Unterstriche zu einem reduzieren
Do While InStr(CleanedName, “__”) > 0
CleanedName = replace(CleanedName, “__”, “_”)
Loop

‘ 5. Führende und abschließende Unterstriche entfernen
If Left(CleanedName, 1) = “_” Then
CleanedName = Mid(CleanedName, 2)
End If
If Right(CleanedName, 1) = “_” Then
CleanedName = Left(CleanedName, Len(CleanedName) – 1)
End If

‘ 6. Auf 8 Zeichen kürzen
If Len(CleanedName) > 8 Then
CleanedName = Left(CleanedName, 8)
End If

‘ 7. Sicherstellen, dass der Name nicht leer ist; falls doch, einen Standardnamen zuweisen
If CleanedName = “” Then
CleanedName = “NO_NAME”
End If

MakeDICOMCompatibleDirName = CleanedName
End Function

Function GetAllFolderPaths(ByVal StartFolder As String) As Collection
Dim fso As Object
Dim folder As Object
Dim subFolder As Object
Dim colPaths As New Collection
Dim subCol As Collection ‘ Deklarieren von subCol
Dim item As Variant ‘ Deklarieren von item

Set fso = CreateObject(“Scripting.FileSystemObject”)

If fso.FolderExists(StartFolder) Then
Set folder = fso.GetFolder(StartFolder)
colPaths.add folder.Path ‘ Füge den aktuellen Ordner hinzu

‘ Rekursiver Aufruf für Unterordner
For Each subFolder In folder.SubFolders
On Error Resume Next ‘ Fehler ignorieren, falls Zugriff verweigert
Set subCol = GetAllFolderPaths(subFolder.Path)
If err.Number = 0 Then
‘ Füge die Pfade der Unterordner zur Hauptsammlung hinzu
For Each item In subCol ‘ ‘item’ ist jetzt deklariert
colPaths.add item
Next item
Else
Debug.Print “Warnung: Zugriff auf Unterordner ‘” & subFolder.Path & “‘ verweigert oder Fehler: ” & err.Description
err.Clear
End If
On Error GoTo 0
Next subFolder
End If

Set GetAllFolderPaths = colPaths
Set fso = Nothing
End Function

Function RenameSingleFolder(ByVal OldFolderPath As String) As String
Dim fso As Object
Dim folderName As String
Dim baseNewFolderName As String ‘ Der initial berechnete DICOM-kompatible Name
Dim newFolderNameAttempt As String ‘ Der Name mit Kollisionsauflösungsversuchen
Dim parentPath As String
Dim newFullPath As String
Dim success As Boolean
Dim retryDigit As Integer
Dim foundUniqueName As Boolean

Set fso = CreateObject(“Scripting.FileSystemObject”)
success = False ‘ Standardmäßig auf Fehler setzen

If Not fso.FolderExists(OldFolderPath) Then
Debug.Print “Fehler: Originalordner ‘” & OldFolderPath & “‘ existiert nicht mehr. Kann nicht umbenannt werden.”
RenameSingleFolder = “”
Exit Function
End If

folderName = fso.GetFolder(OldFolderPath).Name
baseNewFolderName = MakeDICOMCompatibleDirName(folderName) ‘ Den Basis-Namen berechnen

‘ Den vollständigen Zielpfad mit dem Basisnamen bestimmen
parentPath = fso.GetParentFolderName(OldFolderPath)
newFullPath = parentPath & “\” & baseNewFolderName

‘ Sonderfall: Originalpfad und berechneter neuer Pfad sind identisch (auch bei Groß-/Kleinschreibung)
If StrComp(OldFolderPath, newFullPath, vbTextCompare) = 0 Then ‘ Fall-unempfindlicher Vergleich
Debug.Print “Ordner ‘” & OldFolderPath & “‘ ist bereits DICOM-kompatibel und benötigt keine Umbenennung.”
success = True
RenameSingleFolder = OldFolderPath ‘ Pfad bleibt der gleiche
Exit Function
End If

‘ — Kollisionsbehandlung starten —
foundUniqueName = False
newFolderNameAttempt = baseNewFolderName ‘ Starte mit dem Basisnamen

‘ Zuerst versuchen, direkt mit dem Basisnamen umzubenennen (wenn er noch nicht existiert)
If Not fso.FolderExists(newFullPath) Then
foundUniqueName = True
Else
‘ Kollision mit dem Basisnamen erkannt. Versuche, eine eindeutige Variante zu finden.
Debug.Print “Kollision erkannt: Zielordner ‘” & newFullPath & “‘ existiert bereits für ‘” & OldFolderPath & “‘. Versuche, einen eindeutigen Namen zu finden…”

‘ Versuche, das 2. Zeichen durch eine Ziffer (0-9) zu ersetzen
For retryDigit = 0 To 9
‘ Stelle sicher, dass der Name lang genug ist, um das 2. Zeichen zu ersetzen
If Len(baseNewFolderName) >= 2 Then
newFolderNameAttempt = Left(baseNewFolderName, 1) & CStr(retryDigit) & Mid(baseNewFolderName, 3)
Else ‘ Dies sollte durch MakeDICOMCompatibleDirName eigentlich nicht passieren (min. “NO_NAME”)
‘ Falls der Name nur 1 Zeichen lang wäre, hängen wir die Ziffer an.
newFolderNameAttempt = baseNewFolderName & CStr(retryDigit)
End If

‘ Sicherstellen, dass der Name nicht länger als 8 Zeichen wird (falls er durch Anhang länger wurde)
If Len(newFolderNameAttempt) > 8 Then
newFolderNameAttempt = Left(newFolderNameAttempt, 8)
End If

‘ Den vollen Pfad mit dem modifizierten Namen bilden
newFullPath = parentPath & “\” & newFolderNameAttempt

‘ Prüfen, ob dieser neue Name einzigartig ist
If Not fso.FolderExists(newFullPath) Then
foundUniqueName = True
Debug.Print “Eindeutiger Name gefunden: ‘” & newFullPath & “‘ für ‘” & OldFolderPath & “‘”
Exit For ‘ Eindeutigen Namen gefunden, Schleife beenden
End If
Next retryDigit
End If

If Not foundUniqueName Then
Debug.Print “FEHLER: Konnte keinen eindeutigen Namen für ‘” & OldFolderPath & “‘ finden. Alle 10 Kollisionsversuche (” & baseNewFolderName & “[0-9]) sind fehlgeschlagen oder Zielpfad existiert immer noch. Manuelle Lösung erforderlich.”
RenameSingleFolder = “” ‘ Signalisiert das endgültige Scheitern
Exit Function
End If

‘ Fortfahren mit dem Umbenennen unter Verwendung des gefundenen eindeutigen Namens
On Error Resume Next
fso.MoveFolder OldFolderPath, newFullPath
If err.Number <> 0 Then
Debug.Print “FEHLER beim Umbenennen von ‘” & OldFolderPath & “‘ zu ‘” & newFullPath & “‘: ” & err.Description
err.Clear
Else
success = True
End If
On Error GoTo 0

Set fso = Nothing
If success Then
RenameSingleFolder = newFullPath
Else
RenameSingleFolder = “”
End If
End Function

Sub RenameAllDirsOnDongle(ByVal StartPath As String) ‘neu
Dim colAllPaths As Collection
Dim arrPaths() As String
Dim i As Long
Dim j As Long
Dim temp As String
Dim currentOldPath As String
Dim currentNewPath As String
Dim fso As Object

Set fso = CreateObject(“Scripting.FileSystemObject”)

If Not fso.FolderExists(StartPath) Then
MsgBox “Der angegebene Startpfad existiert nicht: ” & StartPath, vbCritical
Exit Sub
End If

‘ Schritt 1: Alle Ordnerpfade sammeln
Set colAllPaths = GetAllFolderPaths(StartPath)

If colAllPaths.Count = 0 Then
MsgBox “Keine umzubenennenden Verzeichnisse im Pfad ‘” & StartPath & “‘ gefunden.”, vbInformation
GoTo CleanUp
End If

‘ Schritt 2: Collection in Array übertragen für Sortierung
ReDim arrPaths(1 To colAllPaths.Count)
For i = 1 To colAllPaths.Count
arrPaths(i) = colAllPaths.item(i)
Next i

‘ Schritt 3: Array nach Pfadlänge absteigend sortieren (längste Pfade zuerst)
‘ Dies stellt sicher, dass tiefere Ordner zuerst umbenannt werden
For i = LBound(arrPaths) To UBound(arrPaths) – 1
For j = i + 1 To UBound(arrPaths)
If Len(arrPaths(i)) < Len(arrPaths(j)) Then
temp = arrPaths(i)
arrPaths(i) = arrPaths(j)
arrPaths(j) = temp
End If
Next j
Next i

‘ Schritt 4: Iteratives Umbenennen der Ordner
For i = LBound(arrPaths) To UBound(arrPaths)
currentOldPath = arrPaths(i)

‘ Der Startpfad (z.B. G:\) kann nicht umbenannt werden, nur seine Unterordner.
‘ Die GetParentFolderName für den Laufwerksbuchstaben gibt einen leeren String zurück.
‘ Wir müssen prüfen, ob es sich um den Root-Pfad handelt.
If currentOldPath = StartPath And Len(fso.GetParentFolderName(currentOldPath)) = 0 And Len(currentOldPath) <= 3 Then
Debug.Print “Überspringe Umbenennung des Laufwerks-Root-Pfades: ” & currentOldPath
GoTo NextPath
End If

currentNewPath = RenameSingleFolder(currentOldPath)

If currentNewPath = “” Then
‘ Fehler beim Umbenennen des aktuellen Pfades, wird bereits in RenameSingleFolder gemeldet.
‘ Wir fahren mit dem nächsten Pfad fort.
ElseIf currentOldPath <> currentNewPath Then
Debug.Print “Umbenannt: ‘” & currentOldPath & “‘ zu ‘” & currentNewPath & “‘”
‘ Optional: Wenn ein Pfad umbenannt wurde, und dies ein Teilpfad eines
‘ später zu verarbeitenden Pfades ist, müsste dieser später angepasst werden.
‘ Durch die Sortierung von tief nach oben ist dies jedoch kein Problem,
‘ da die Elternordner erst nach den Kindern verarbeitet werden.
Else
Debug.Print “Keine Umbenennung nötig für: ‘” & currentOldPath & “‘”
End If
NextPath:
Next i

MsgBox “Der Umbenennungsprozess wurde abgeschlossen. Überprüfen Sie bitte den Dongle ‘” & StartPath & “‘ auf eventuelle Fehler in den Debug.Print-Ausgaben (Strg+G im VBA-Editor).”, vbInformation

CleanUp:
Set fso = Nothing
End Sub