VBA backup maken van bovenliggende MAP

[AD1957]

Onderstaande code (gevonden op dit forum) maakt een backup bij afsluiten. (backup op externe schijf G)
Tevens worden alle oude backups (behalve de laatste 3) verwijderd. werkt perfect:d

Is het ook mogelijk om deze code zo te schrijven dat er van de Bovenliggende Map een backup wordt gemaakt.?

Const sPad = "G:\BACKUP TESTEN(1)\" 'DIT IS DE SCHIJF EN MAP WAARIN WORDT OPGESLAGEN

Function SelectionSort(TempArray As Variant)
Dim MaxVal As Variant, MaxIndex As Long
Dim i As Integer, j As Integer

    ' Step through the elements in the array starting with the last element in the array.
    For i = UBound(TempArray, 1) To 1 Step -1
        ' Set MaxVal to the element in the array and save the index of this element as MaxIndex.
        MaxVal = TempArray(i)
        MaxIndex = i
        ' Loop through the remaining elements to see if any is larger than MaxVal.
        ' If it is then set this element to be the new MaxVal.
        For j = 1 To i
            If TempArray(j) > MaxVal Then
                MaxVal = TempArray(j)
                MaxIndex = j
            End If
        Next j
        ' If the index of the largest element is not i, then exchange this element with element i.
        If MaxIndex < i Then
            TempArray(MaxIndex) = TempArray(i)
            TempArray(i) = MaxVal
        End If
    Next i
End Function


Private Sub Workbook_BeforeClose(Cancel As Boolean)
ActiveWorkbook.Save
    ' Beginnen met het eerste Excel bestand opzoeken in de standaardmap
    MijnBestand = Dir(sPad & "*.xls")

    ReDim tmp(0)
    i = 0
    'vervolgens alle bestanden in een matrix variabele zetten.
    Do While MijnBestand <> ""
        ReDim Preserve tmp(i)
        tmp(i) = MijnBestand
        i = i + 1
        MijnBestand = Dir
    Loop

    ' Dan de matrix sorteren ...
    Call SelectionSort(tmp)

    ' ... "verwijder alle oude backups behalve de laatste 3
    For i = 0 To UBound(tmp) - 3
        On Error Resume Next
        Kill sPad & tmp(i)
    Next i

    ' En dan natuurlijk een nieuwe backup maken!
    ActiveWorkbook.SaveCopyAs sPad & Format(Now, "yyyy") & Sheets("Blad1").Range("D7").Value & " " & ActiveWorkbook.Name


End Sub

 

[AD1957]

Gevonden op de site van Ron de Bruijn https://www.rondebruin.nl/win/s3/win026.htm

 Private Sub CommandButton1_Click()
[COLOR="#008000"]'This example copy all files and subfolders from FromPath to ToPath.
'Note: If ToPath already exist it will overwrite existing files in this folder
'if ToPath not exist it will be made for you.[/COLOR]
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\" & Environ("username") & "\Desktop\onderhoud cv"
[COLOR="#008000"]'    ToPath = "G:\BACKUP onderhoud cv"  [/COLOR]                                   [COLOR="#008000"]'backup wordt steeds overschreven[/COLOR]
    ToPath = "G:\BACKUP onderhoud cv\" & Format(Now, "yyyy-mm-dd h-mm-ss") 'er wordt steeds een nieuwe backup gemaakt in de map G:\Backup onderhoud cv

    [COLOR="#008000"]'If you want to create a backup of your folder every time you run this macro
    'you can create a unique folder with a Date/Time stamp.
    'ToPath = "C:\Users\Ron\" & Format(Now, "yyyy-mm-dd h-mm-ss")
[/COLOR]
    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set FSO = CreateObject("scripting.filesystemobject")

    If FSO.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
   MsgBox "Een backup is gemaakt op de externe harde schijf" & " in " & ToPath
[COLOR="#008000"]'    MsgBox "You can find the files and subfolders from " & FromPath & " in " & ToPath[/COLOR]
End Sub

Nu alleen nog eens kijken of alleen de laatste 3 backups in de backupfolder blijven staan.
Heeft iemand een oplossing.?

 

[cow18]

daarmee bedoel je de 3 laatste subdirectories ?
Wel een beetje moeilijk geschreven die macro

 

[AD1957]

Hallo Cow18,

Wat ik bedoel is het volgende:
Zodra 4 backups in de map G:\BACKUP onderhoud cv staan zou de oudste backup moeten worden verwijderd.

Voor mijn gebruik kan de macro waarschijnlijk een stuk korter, voor het gemak heb ik de macro van Ron de Bruijn even helemaal geplaatst.

 

[AD1957]

Hier heb ik voldoende aan:

Private Sub CommandButton1_Click()

    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String

    FromPath = "C:\Users\" & Environ("username") & "\Desktop\onderhoud cv"
    ToPath = "G:\BACKUP onderhoud cv\" & Format(Now, "yyyy-mm-dd h-mm-ss") [COLOR="#008000"]'er wordt steeds een nieuwe backup gemaakt in de map G:\Backup onderhoud cv[/COLOR]

    Set FSO = CreateObject("scripting.filesystemobject")

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    [COLOR="#008000"]'MsgBox "Een backup is gemaakt op de externe harde schijf" & " in " & ToPath[/COLOR]

End Sub

Nu alleen nog een oplossing voor de vraag in #4

 

[HSV]

Loop de code met F8 door.
Zet vooraf een onderbrekingspunt bij de twee blauwe regels met F9, zodat je kan zien of je het juiste bestand verwijderd in de testfase.
Zo niet?, breek de code af

Private Sub CommandButton1_Click()
Dim FSO As Object, sFile, a as string, bestand as string
    Dim FromPath As String
    Dim ToPath As String


    FromPath =[COLOR=#ff0000] Environ("userprofile") [/COLOR]& "\Desktop\onderhoud cv"
    ToPath = "G:\BACKUP onderhoud cv\" & Format(Now, "yyyy-mm-dd h-mm-ss") 'er wordt steeds een nieuwe backup gemaakt in de map G:\Backup onderhoud cv


    Set FSO = CreateObject("scripting.filesystemobject")


    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    'MsgBox "Een backup is gemaakt op de externe harde schijf" & " in " & ToPath



[COLOR=#ff0000] If FSO.GetFolder(ToPath).Files.Count > 3 Then[/COLOR]
[COLOR=#ff0000]    For Each sFile In FSO.Files[/COLOR]
[COLOR=#ff0000]     If a < sFile.datecreated Then  [/COLOR]'of sfile.datelastmodified
[COLOR=#ff0000]        a = sFile.datecreated          [/COLOR]'of sfile.datelastmodified
[COLOR=#ff0000]        bestand = sFile.Path[/COLOR]
[COLOR=#ff0000]     End If[/COLOR]
[COLOR=#ff0000]    Next[/COLOR]
[COLOR=#ff0000]   End If
[/COLOR][COLOR=#0000ff]msgbox bestand[/COLOR]
[COLOR=#0000ff]FSO.deletefile bestand[/COLOR][COLOR=#ff0000]
[/COLOR]
End Sub

Het kan ook met,

 FSO.deletefile Split(CreateObject("Wscript.Shell").Exec("cmd /c dir ""& ToPath & "\*.xls"" /od /a-d /b").StdOut.ReadAll, vbLf)(0), , "Oldest File"

in plaats van de lus.

 

[AD1957]

Goedemorgen Harry,

Beide codes geven een foutmelding, waarschijnlijk omdat ze Files\bestanden willen verwijderen.
De bedoeling is echter dat subfolders worden verwijderd.
Voor zekerheid getest op een USB stick.

Zelf deze code geprobeerd maar die loopt ook vast.

Dim FSO As Object
 Dim folder As Object
 Dim subfolders As Object
 Dim FromPath As String
 Dim ToPath As String
 
 'TEL HET HUIDIGE AANTAL BACKUPS
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Set folder = FSO.GetFolder("F:\BACKUP onderhoud cv ")
 Set subfolders = folder.subfolders
    i = subfolders.Count
    MsgBox i
    
'MAAK EEN NIEUWE BACKUP
FromPath = Environ("userprofile") & "\Desktop\onderhoud cv"
ToPath = "F:\BACKUP onderhoud cv\" & Format(Now, "yyyy-mm-dd h-mm-ss") 'er wordt steeds een nieuwe backup gemaakt in de map G:\Backup onderhoud cv
FSO.CopyFolder Source:=FromPath, Destination:=ToPath

i = subfolders.Count 'nieuw aantal backups
MsgBox i

'VERWIJDEREN VAN OUDE BACKUPS INDIEN MEER DAN 4 STUKS

    Do While i > 4
        objOldest = Now
       For Each subfolder In subfolders
         If Not IsObject(objOldest) Then
           ' Save first subfolder
           Set objOldest = subfolder
          ' WScript.Echo objOldest
         Else
    '        Save older subfolder
           If subfolder.datecreated < objOldest.datecreated Then
             Set objOldest = subfolder
            objOldest.Delete
           End If
         End If
        Next
      i = subfolders.Count
    Loop

Mijn kennis van VBA is te gering om tot een oplossing te komen.

 

[cow18]

veel meer dan dit moet het niet zijn, denk ik. Het verwijderen van de bestanden en de subdirectory staat voorlopig uitgeschakeld.
Je verzamelt eerst al je subdirectories, stop die in lijst en sorteert die, eventueel omgekeerd en dan laat de de 1e 3 staan en verwijdert de rest
Toch best nog op je USB uittesten !

Sub Verwijderen()
   topath = "c:\users\eigenaar\downloads"        'je path
   sp = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & topath & " /od /ad /b").StdOut.ReadAll, vbCrLf)   'array met alle subdirectories

   Set sca = CreateObject("System.Collections.ArrayList")   'aanmaak van een gesorteerde lijst
   For i = 0 To UBound(sp)                       'alle subdirectories in je array aflopen
      sca.Add CStr(sp(i))                        'toevoegen aan lijst
   Next
   sca.Sort                                      'sorteren
   'sca.reverse'eventueel sortering omdraaien
   
   If sca.Count > 3 Then                         'indien meer dan 3 subdirectories
      arr = sca.toarray                          'list kopieren naar array
      For i = 3 To UBound(arr)                   'vanaf de 4e (ps. je start bij 0)
         MsgBox arr(i)                           'zeg de subdirectory
         'Kill arr(i) & "\*.*"                    'eerst alle bestanden wissen
         'RmDir arr(i)                            'dan subdirectory weg
      Next
   End If
End Sub

mogelijks moet het Cstr(arr(i)) zijn ipv arr(i) als je op een fout loopt
2e mogelijke fout : misschien toPath & "" & arr(i)
eigenaardig, maar er moet een backslash tussen die aanhalingstekens staan, maar de site weigert die te zetten, een bugje.

 

[AD1957]

Hallo Cow18,

Ik zal jouw code zeker gaan uitproberen, dank hiervoor. (eerst maar eens goed bestuderen)

Zelf was ik er ook al uit met onderstaande code. Eerst een nieuwe backup maken en dan de oude (meer dan 4) verwijderen.
En zoals je al aangaf, eerst getest op een USB stick.

Private Sub CommandButton5_Click() 'maken backup en verwijderen van meer dan 4
    Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Set FSO = CreateObject("scripting.filesystemobject")
    
    FromPath = "C:\Users\" & Environ("username") & "\Desktop\onderhoud cv"
    ToPath = "F:\BACKUP onderhoud cv\" & Format(Now, "yyyy-mm-dd h-mm-ss") 'er wordt steeds een nieuwe backup gemaakt op de USB stick F:\Backup onderhoud cv

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "Een backup is gemaakt op de externe harde schijf" & " in " & ToPath
    
    
    
'verwijderen oude backups indien meer dan 4
    

 Set folder = FSO.GetFolder("F:\BACKUP onderhoud cv ")
 Set subfolders = folder.subfolders
'    i = subfolders.Count
'    MsgBox i

 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Set objDrive = objFSO.GetDrive("F:") 'USB stick

 Set Directory = FSO.GetFolder("F:\BACKUP onderhoud cv") 'USB stick
 Set subfolders = Directory.subfolders


i = subfolders.Count
    Do While i > 4
       objOldest = Now
       For Each subfolder In subfolders
         If Not IsObject(objOldest) Then
           ' Save first subfolder
           Set objOldest = subfolder
         Else
           ' Save older subfolder
           If subfolder.datecreated < objOldest.datecreated Then
             Set objOldest = subfolder
           End If
         End If
       Next
     
       objOldest.Delete
        
       i = subfolders.Count
    
    Loop
End Sub

 

[AD1957]

jouw code doet bij mij helemaal niets.
Wat ik nog niet heb gewijzigd = misschien toPath & "" & arr(i)
Ik heb nml geen idee in welke regel dit zou moeten.
Wijzigen van arr(i) in Cstr(arr(i)) maakt ook niets uit.

topath = "F:\BACKUP onderhoud cv"         'je path
   sp = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & topath & " /od /ad /b").StdOut.ReadAll, vbCrLf)   'array met alle subdirectories

   Set sca = CreateObject("System.Collections.ArrayList")   'aanmaak van een gesorteerde lijst
   For i = 0 To UBound(sp)                       'alle subdirectories in je array aflopen
      sca.Add CStr(sp(i))                        'toevoegen aan lijst
   Next
   sca.Sort                                      'sorteren
   'sca.reverse'eventueel sortering omdraaien
   
   If sca.Count > 3 Then                         'indien meer dan 3 subdirectories
      arr = sca.toarray                          'list kopieren naar array
      For i = 3 To UBound(arr)                   'vanaf de 4e (ps. je start bij 0)
         MsgBox arr(i)                           'zeg de subdirectory
         Kill arr(i) & "\*.*"                    'eerst alle bestanden wissen
         RmDir arr(i)                            'dan subdirectory weg
      Next
   End If

 

[cow18]

Sub CV()
   topath = "F:\BACKUP onderhoud cv"             'je path
   topath = "c:\users\eigenaar\downloads\testmap"   'je path

   sp = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & topath & " /od /ad /b").StdOut.ReadAll, vbCrLf)   'array met alle subdirectories

   Set sca = CreateObject("System.Collections.ArrayList")   'aanmaak van een gesorteerde lijst
   For i = 0 To UBound(sp)                       'alle subdirectories in je array aflopen
      If Len(sp(i)) Then sca.Add CStr(sp(i))     'toevoegen aan lijst
   Next
   sca.Sort                                      'sorteren
   sca.Reverse                                   'sortering omdraaien

   If sca.Count > 3 Then                         'indien meer dan 3 subdirectories
      arr = sca.toarray                          'list kopieren naar array
      MsgBox "deze directories blijven gespaard : " & vbLf & Join(Application.Index(arr, Array(1, 2, 3)), vbLf)
      For i = 3 To UBound(arr)                   'vanaf de 4e (ps. je start bij 0)
         MsgBox arr(i)                           'zeg de te wissen subdirectory
         On Error Resume Next
         Kill topath & "\" & arr(i) & "\*.*"     'eerst alle bestanden wissen, indien aanwezig, daarom die on error
         On Error GoTo 0
         RmDir topath & "\" & arr(i)             'dan subdirectory weg
      Next
   End If
End Sub

 

[AD1957]

Sorry maar krijg de code niet aan de praat en kan niet ontdekken waarom.(te weinig inzicht in de code)
Geen foutmeldingen maar er gebeurt ook niets.(er zijn 7 submappen)

Misschien een onbescheiden vraag, maar heb je de code zelf getest op een USB-stick



p.s. De code die in #9 staat werkt wel die ga ik dus vooralsnog gebruiken.

 

[HSV]

Ja, ik meende dat het om bestanden ging i.p.v. mappen.

 

[cow18]

getest op de C:, niet op een USB, maar normaal zou dat niet kunnen uitmaken.
Bon, jij bent tevreden, ik dus ook.

 

[AD1957]

Hallo cow18,

Ik blijf toch maar bezig met jouw code, vreemd dat deze bij mij niet werkt.
Toch maar eens 2 MsgBox er tussen gezet: MsgBox UBound(sp), MsgBox LBound(sp)
Blijkbaar gaat er toch iets mis, Ubound(sp)=-1
Zelf kom ik er niet achter.

Private Sub CommandButton1_Click()
Dim FSO As Object
    Dim FromPath As String
    Dim ToPath As String
    Dim BackupMap As String
    Set FSO = CreateObject("scripting.filesystemobject")
    Dim arr
   [COLOR="#008000"] 'aanmaken nieuwe backup[/COLOR]
    FromPath = Environ("userprofile") & "\Desktop\onderhoud cv"
    ToPath = Environ("userprofile") & "\downloads\testmap\" & Format(Now, "yyyy-mm-dd h-mm-ss")

    FSO.CopyFolder Source:=FromPath, Destination:=ToPath
    MsgBox "Een backup is gemaakt op de externe harde schijf" & " in " & ToPath


Range("D3").Value = Range("D3").Value + 1


[COLOR="#008000"]'verwijder oude backups als er meer dan 4 in de testmap staan[/COLOR]
   BackupMap = Environ("userprofile") & "\downloads\testmap"    'je path
  
   sp = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & BackupMap & " /od /ad /b").StdOut.ReadAll, vbCrLf)  [COLOR="#008000"] 'array met alle subdirectories[/COLOR]
   
[COLOR="#FF0000"]MsgBox UBound(sp)
MsgBox LBound(sp)[/COLOR]

   Set sca = CreateObject("System.Collections.ArrayList")   [COLOR="#008000"]'aanmaak van een gesorteerde lijst[/COLOR]
   For i = 0 To UBound(sp)                       [COLOR="#008000"]'alle subdirectories in je array aflopen[/COLOR]
      If Len(sp(i)) Then sca.Add CStr(sp(i))    [COLOR="#008000"] 'toevoegen aan lijst[/COLOR]
   Next
   sca.Sort                                     [COLOR="#008000"] 'sorteren[/COLOR]
   sca.Reverse                                   [COLOR="#008000"]'sortering omdraaien[/COLOR]

   If sca.Count > 3 Then                        [COLOR="#008000"] 'indien meer dan 3 subdirectories[/COLOR]
      arr = sca.toarray                          [COLOR="#008000"]'list kopieren naar array[/COLOR]
      MsgBox "deze directories blijven gespaard : " & vbLf & Join(Application.Index(arr, Array(1, 2, 3)), vbLf)
      For i = 3 To UBound(arr)                  [COLOR="#008000"] 'vanaf de 4e (ps. je start bij 0[/COLOR])
         MsgBox arr(i)                          [COLOR="#008000"] 'zeg de te wissen subdirectory[/COLOR]
         On Error Resume Next
         Kill BackupMap & "\" & arr(i) & "\*.*"     [COLOR="#008000"]'eerst alle bestanden wissen, indien aanwezig, daarom die on error[/COLOR]
         On Error GoTo 0
         RmDir BackupMap & "\" & arr(i)            [COLOR="#008000"] 'dan subdirectory weg[/COLOR]
      Next
   End If

End Sub

 

[HSV]

Oudste submap verwijderen uit hoofdmap.

Private Sub CommandButton1_Click()Dim FSO As Object, sFolder, a As String, map As String
Dim FromPath As String
Dim ToPath As String
  FromPath = Environ("userprofile") & "\Desktop\onderhoud cv"
  ToPath = "G:\BACKUP onderhoud cv\" & Format(Now, "yyyy-mm-dd h-mm-ss") 'er wordt steeds een nieuwe backup gemaakt in de map G:\Backup onderhoud cv
    Set FSO = CreateObject("scripting.filesystemobject")
       FSO.CopyFolder Source:=FromPath, Destination:=ToPath
       MsgBox "Een backup is gemaakt op de externe harde schijf" & " in " & ToPath
 If FSO.getfolder(ToPath).subfolders.Count > 3 Then
    For Each sFolder In FSO.getfolder(ToPath).subfolders
      If a < DateValue(sFolder.datecreated) Then  'of .datelastmodified
        a = DateValue(sFolder.datecreated)          'of .datelastmodified
        map = sFolder.Path
      End If
   Next
 FSO.deletefolder bestand
End If
End Sub

 

[AD1957]

Harry,

na enkele kleine wijzigingen loopt de code goed.

Private Sub CommandButton1_Click()
Dim FSO As Object, sFolder, a As String, map As String
Dim FromPath As String
Dim ToPath As String
Dim BackupPath As String

  FromPath = Environ("userprofile") & "\Desktop\onderhoud cv"
  ToPath = "G:\BACKUP onderhoud cv\" & Format(Now, "yyyy-mm-dd h-mm-ss")
    Set FSO = CreateObject("scripting.filesystemobject")
       FSO.CopyFolder Source:=FromPath, Destination:=ToPath
       MsgBox "Een backup is gemaakt op de externe harde schijf" & " in " & ToPath

[COLOR="#FF0000"]BackupPath = "G:\BACKUP onderhoud cv"[/COLOR]

 If FSO.getfolder([COLOR="#FF0000"]BackupPath[/COLOR]).subfolders.Count > 4 Then [COLOR="#008000"]'als meer dan 4 back-ups oudste verwijdern code van HSV[/COLOR]
    For Each sFolder In FSO.getfolder([COLOR="#FF0000"]BackupPath[/COLOR]).subfolders
      If a < DateValue(sFolder.datelastmodified) Then
        a = DateValue(sFolder.datelastmodified)
        map = sFolder.Path
      End If
   Next
   FSO.deletefolder [COLOR="#FF0000"]map[/COLOR]
End If
End Sub

Bedankt Harry en ook cow18, zet de vraag als opgelost