älteste Ordner löschen (anzahl Ordner auf max. 4 begrenzen)

Hallo, ich hoffe, das mir jemand weiterhelfen kann.

Folgendes Problem:
Ich erhalte zu unterschiedlichen Tagen Datenbanken per Mail welche per Skript eingespielt werden ( dieses geschieht per VBA) , wobei vorher ein Backup des org. Ordners angelegt wird (xxxxx_Datum_Uhrzeit, jeweils ohne Punkt).

'Emails aus Outlook auslesen  


  Dim objOL As Object, objFolder As Object
  Dim strPath As String
  Dim lngIndex As Long, lngCur As Long, lngCount As Long, lngRow As Long
  
  On Error Resume Next
  
  If Dir("C:\temp", vbDirectory) = "" Then  
  MkDir ("C:\temp")  
  End If
  strPath = "c:\Temp" 'Speicherpfad - Anpassen!  
  
  strPath = IIf(right(strPath, 1) = "\", strPath, strPath & "\")  
  
  Set objOL = CreateObject("Outlook.Application")  
  Set objFolder = objOL.GetNamespace("MAPI").GetDefaultFolder(6)  
  
  lngCount = objFolder.Items.Count
  
  lngRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
  
  For lngCur = 1 To lngCount

Forms![01_01_Updateprüfung].SetFocus
Me.Refresh
Me.Requery

Me.Hinweistext.Caption = "Prüfe auf neue DB Mails..."  
Forms![01_01_Updateprüfung].SetFocus
Me.Refresh
Me.Requery


    With objFolder.Items(lngCur)
    Const SB As String = "Automatischer Versand BackEnd-DB (komplett)"  
      If InStr(.Subject, SB) > 0 Then
                If .Attachments.Count > 0 Then
          For lngIndex = 1 To .Attachments.Count
            .Attachments.Item(lngIndex).SaveAsFile strPath & .Attachments.Item(lngIndex).FileName
          Next
        End If
        
        Forms![01_01_Updateprüfung].SetFocus
        Me.Refresh
        Me.Requery

        Me.Hinweistext.Caption = "Kopiere DB-Anhänge lokal und entferne Mails aus Postfach.."  
        Forms![01_01_Updateprüfung].SetFocus
        Me.Refresh
        Me.Requery

        '.UnRead = False 'als gelesen markieren  
        .Delete 'Löschen  
      End If
    End With
  Next
  
  
  Set objFolder = Nothing
  Set objOL = Nothing

'ende Outlook auslesen  


'vorabprüfung  
If Dir("C:\temp\DB.7z.001") <> "" Then  

Forms![01_01_Updateprüfung].SetFocus
Me.Refresh
Me.Requery

Me.Hinweistext.Caption = "ZIP Datei Komplettupdate DB gefunden..."  
Forms![01_01_Updateprüfung].SetFocus
Me.Refresh
Me.Requery

'Backupdatei erzeugen  

sDT = Format(Date, "ddMMyyyy") & "_" & Format(Time, "HHMMSS")  
 DirCopy "C:\SERVER\BE", "C:\SERVER\BE_" & sDT  

....

Nun möchte ich aber erreichen, dass nach einspielen der Datenbank die Anzahl der Ordner xxxxx_Datum_Uhrzeit geprüft wird und nur die jüngsten 4 erhalten bleiben, alle anderen des Formats sollen ungefragt gelöscht werden.

Der normale Kill Befehl ist mir bekannt, nur weis ich nicht wie ich die Anzahl der Ordner bestimmen, und nur die 4 jüngsten beibehalten und die anderen per VBA löschen kann.

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 375037

Url: https://administrator.de/forum/aelteste-ordner-loeschen-anzahl-ordner-auf-max-4-begrenzen-375037.html

Ausgedruckt am: 23.12.2024 um 01:12 Uhr

1 Kommentar

Ich gehe von folgendem Format der Ordner aus:
xxxxx_DDMMYYYY_HHMMSS

Wenn anders, dann Regex in Zeile 20 anpassen.

Ordner anpassen, feedich.

Const ORDNER = "D:\Daten"  
Const NUMHOLD = 4
Set fso = CreateObject("Scripting.Filesystemobject")  

Set result = SortFolders(ORDNER)
result.MoveFirst
If result.RecordCount > NUMHOLD Then
	result.Move NUMHOLD
	While Not result.EOF
		fso.DeleteFolder result.Fields("Name").Value, True  
		result.MoveNext
	Wend

End If

Function SortFolders(strFolder)
	Set objList = CreateObject("ADOR.Recordset")  
	Set fso = CreateObject("Scripting.Filesystemobject")  
	Set regex = CreateObject("vbscript.regexp")  
	regex.Pattern = "[^_]+_((\d{2})(\d{2})(\d{4}))_(\d{6})"  

	objList.Fields.Append "name", 200, 255  
	objList.Fields.Append "date", 7  
	objList.Open
	If fso.FolderExists(strFolder) then
		For Each folder In fso.GetFolder(strFolder).SubFolders
			set matches = regex.Execute(folder.Name)
			If matches.Count > 0 Then
				objList.AddNew
				objList("name").Value = folder.Path  
				objList("date").Value = CDate(matches(0).submatches(1) & "." & matches(0).submatches(2) & "." & matches(0).submatches(3))  
				objList.Update
			End If
		Next
	End If
	objList.Sort = "date DESC"  
	Set SortFolders = objList
	Set fso = Nothing
	Set objList = Nothing
End Function