AW: Ordnerpfade in Objekt schreiben, filtern und löschen
01.11.2019 14:49:03
Dominik
Guten Tag euch allen,
ich habe einen Weg für mein Problem gefunden und es nun hinbekommen. Sicherlich kann man hier noch viel optimieren (Benennungen, Länge und Aufbau,...). Nach ein Paar Test scheint es aber wie gewünscht zu funktionieren. Falls jemand den Code noch optimieren kann wäre ich dankbar. Ihr findet unten meine Lösung sowie die entsprechenden Link aus denen ich den Code "zusammengebaut" habe.
!!!Achtung!!!: Bitte den Code mit Vorsicht nochmal selbst versuchen. Die Löschenfunktion ist ohne doppelten Boden. Hierdurch entsteht eventuell Datenverlust.
Ich wünsche euch einen schönen Feiertag.
Gruß
Dominik
Sub AlteSicherungenLoeschen() 'Quelle https://www.herber.de/forum/archiv/572to576/572340_Ordner_auflisten_aber_wie.html
Dim fso As Object
Dim myfolder As Object
Dim myfile As Object
Dim strOrdnerName As String
Dim objPotenzielleListe As Object
Dim objPotenziellerPfad As Object
Dim intMax As Integer
Dim intBisEintragLoeschen As Integer
Dim intZaehler As Integer
Dim objLoeschenListe As Object
Dim objLoeschenPfad As Object
Dim strZiel
strZiel = "C:\Users\Dominik\Desktop\Test2"
If Right(strZiel, 1) "\" Then strZiel = strZiel & "\" 'ggf. noch Schrägstrich hinzufüge
intMax = 0
intZaehler = 1
Set fso = CreateObject("scripting.filesystemobject")
Set myfolder = fso.GetFolder(strZiel)
Set objPotenzielleListe = CreateObject("Scripting.Dictionary")
Set objLoeschenListe = CreateObject("Scripting.Dictionary")
For Each myfile In myfolder.SubFolders _
'1.) Start: Nur Pfade die die richtig Bezeichnung haben auswählen
strOrdnerName = NameOrdnerImZielErmitteln(CStr(myfile)) 'Name des Sicherungsordners
If strOrdnerName Like "Sicherung-" & "*" Then 'prüfen ob es sich um _
Sicherungsordner handelt
'Debug.Print myfile & " löschen"
objPotenzielleListe.Add myfile, 1
Else
'Diese Ordner können aus der Liste entfernt werden/ sollen nicht gelöscht werden
'Debug.Print myfile & " nicht löschen"
End If
Next myfile _
'1.) Ende
intMax = objPotenzielleListe.Count '2.) Start: Die zu Löschenden Pfade siehe auch Quelle https://docs.microsoft.com/de-de/office/vba/language/reference/user-interface-help/dictionary-object
intBisEintragLoeschen = intMax - 2 _
'Bestimmung der Anzahl an Pfade die bestehen bleiben sollten Maximale Anzahl im Ordner - Anzahl an verbleibenden Kopien
For Each objPotenziellerPfad In objPotenzielleListe _
'2.) Nimmt in Liste zum Löschen nur die Pfade auf die gelöscht werden sollten
If intZaehler https://www.herber.de/forum/archiv/1264to1268/1265709_Ordner_per_VBA_loeschen.html
Case vbOK
For Each objLoeschenPfad In objLoeschenListe
Call AlleDateienLoeschen(CStr(objLoeschenPfad), True, True) 'Unterordner + Dateien im _
Pfad löschen Überornder bleibt bestehen erstes True für Unterordner zweites True für Überordner
Next objLoeschenPfad
Case vbCancel
'keine Anweisung bisher
End Select _
'3.) Ende
Set myfolder = Nothing
Set fso = Nothing
Set myfile = Nothing
Set objPotenzielleListe = Nothing
Set objPotenziellerPfad = Nothing
Set objLoeschenListe = Nothing
Set objLoeschenPfad = Nothing
End Sub
Function NameOrdnerImZielErmitteln(strPfad As String) 'Quelle https://www.herber.de/forum/archiv/424to428/427909_Text_mit_VBA_splitten.html
NameOrdnerImZielErmitteln = Right(strPfad, InStr(1, StrReverse(strPfad), "\") - 1)
End Function
Function UebergeordnerterOrdnerPfadErmitteln(strPfad As String) 'Quelle https://www.herber.de/forum/archiv/424to428/427909_Text_mit_VBA_splitten.html
UebergeordnerterOrdnerPfadErmitteln = Left(strPfad, InStr(1, StrReverse(strPfad), "\") + 1)
End Function
Public Sub AlleDateienLoeschen(Ordnerpfad As String, _
Optional UnterordnerLoeschen As Boolean, Optional UeberordnerLoeschen As Boolean) 'Quelle: https://dbwiki.net/wiki/VBA_Tipp:_Alle_Dateien_und_Unterverzeichnisse_in_einem_Verzeichnis_l%C3%B6schen
' Ordnerpfad: Pfad zum Verzeichnis, in dem die Dateien gelöscht werden sollen
' UnterordnerLoeschen: Wenn True, werden zusätzlich auch alle Unterverzeichnisse gelöscht
' UeberordnerLoeschen: Wenn True, werden zusätzlich auch alle Überverzeichnisse gelöscht
' Late Binding, kein Verweis auf "Microsoft Scripting Runtime" notwendig
' Quelle: www.dbwiki.net oder www.dbwiki.de
Dim strDir As String
Dim fso As Object 'Scripting.FileSystemObject
Dim geloescht As Boolean
Dim strUeberOrdnerPfad As String
Dim strUeberordnerZuLoeschen As String
strUeberOrdnerPfad = modLoeschenAlterSicherunge.UebergeordnerterOrdnerPfadErmitteln( _
Ordnerpfad)
strUeberordnerZuLoeschen = modLoeschenAlterSicherunge.NameOrdnerImZielErmitteln(Ordnerpfad)
' Backslash am Ende des Pfads hinzufügen, falls er fehlt
If Right$(Ordnerpfad, 1) "\" Then
Ordnerpfad = Ordnerpfad & "\"
End If
' Objektvariable mit FileSystemObject erstellen
Set fso = CreateObject("Scripting.FileSystemObject")
' Erste Datei oder Unterordner im Überordner suchen
strDir = Dir(strUeberOrdnerPfad, vbNormal Or vbDirectory)
' Wenn mindestens eine Überordner existiert, alle Dateien löschen
If strDir vbNullString Then
' Schleife beginnen.
Do Until strDir = vbNullString
' wenn die Überordner auch gelöscht werden sollen
If UeberordnerLoeschen Then
' Mit bit-weisem Vergleich sicherstellen, dass strDir ein Verzeichnis ist.
If (GetAttr(strUeberOrdnerPfad & strDir) And vbDirectory) = vbDirectory Then
' Überordner mit oder ohne Inhalt löschen, auch schreibgeschützte (außer . _
und ..)
If strDir "." And strDir ".." And strDir = strUeberordnerZuLoeschen _
Then
fso.DeleteFolder strUeberOrdnerPfad & strDir, True
geloescht = True
End If
End If
' Nächsten Eintrag abrufen
strDir = Dir
Else
'*****Ursprünglicher Programmcode*******
' Erste Datei oder Unterordner im Ordner suchen
strDir = Dir(Ordnerpfad, vbNormal Or vbDirectory)
' Wenn mindestens eine Datei existiert, alle Dateien löschen
If strDir vbNullString Then
' Schleife beginnen.
Do Until strDir = vbNullString
' Initialisierung
geloescht = False
' wenn die Unterordner auch gelöscht werden sollen
If UnterordnerLoeschen Then
' Mit bit-weisem Vergleich sicherstellen, dass strDir ein _
Verzeichnis ist.
If (GetAttr(Ordnerpfad & strDir) And vbDirectory) = vbDirectory _
Then
' Ordner mit oder ohne Inhalt löschen, auch schreibgeschützte _
(außer . und ..)
If strDir "." And strDir ".." Then
fso.DeleteFolder Ordnerpfad & strDir, True
geloescht = True
End If
End If
End If
' Wenn vorher kein Verzeichnis gelöscht wurde
If geloescht = False Then
' Mit bit-weisem Vergleich sicherstellen, dass strDir kein _
Verzeichnis ist.
If (GetAttr(Ordnerpfad & strDir) And vbDirectory) vbDirectory _
Then
' Datei löschen, auch schreibgeschützte
fso.DeleteFile Ordnerpfad & strDir, True
End If
End If
' Nächsten Eintrag abrufen
strDir = Dir
Loop
End If
'*****Ursprünglicher Programmcode*******
End If
Loop
End If
Set fso = Nothing
End Sub