1
ä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).
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.
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.
Share on Facebook
Share on Twitter
Share on Reddit
Share on LinkedinPlease also mark the comments that contributed to the solution of the article
Content-Key: 375037
Url: https://administrator.de/contentid/375037
Printed on: April 20, 2024 at 01:04 o'clock
1 Comment
Ich gehe von folgendem Format der Ordner aus:
Wenn anders, dann Regex in Zeile 20 anpassen.
Ordner anpassen, feedich.
xxxxx_DDMMYYYY_HHMMSSWenn 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
