MS Excel

Téma: cyklické zálohování

Zaslal/a Milan-158 18.7.2023 16:54

Ahoj vespolek,

Ohledně automatického zálohování (abychom neztratili neuloženou práci) už zde příspěvek byl, ale toto je něco jiného. Už roky používám u důležitých souborů, (kde to má význam) cyklické zálohování. Určím, že v určitém adresáři bude n (10 nebo klidně i 100) záloh, které se budou cyklicky přepisovat (tedy vždy ta nejstarší záloha), pokud od času uložení poslední zálohy uplyne jistý čas (např. 2 hod nebo 2 dny).
Jaký to má význam? Třeba po čase zjistím, že mi někdo (nebo třeba i já) omylem něco smazal nebo pozměnil. Tak jdu do seznamu záloh a tam to najdu ještě v původním stavu a mám to podle čeho obnovit - pokud mám správně zvolený ukládací interval a počet záloh. Procedura se sama spouští při otevírání souboru (v některých případech i při zavírání). Už mi to párkrát významně pomohlo, tak třeba se to někomu hodí...
Sub ZalohaSouboru()
'na definovaném místě vytvoří n záložních souborů a do toho nejstaršího vždy uloží aktuální zálohu
'zálohu to vytváří pouze pokud od datumu/času poslední uložené zálohy uplynula nějaká doba
'tato časová konstanta (sgInterval) je v této proceduře nastavena na 2 dny (48 hodin)

Const n As Integer = 9 'n = počet záložních souborů, které budeme používat
Const sgInterval As Single = 2 '2 dny = 48 hodin. Tím pádem hloubka historie je n * sgInterval = 9 * 2 = 10 dnů

Dim strNazev As String, strPath As String, strName As String
Dim dDatum As Date, dDatum_Max As Date, dDatum_Min As Date
Dim i As Integer, iNejstarsi As Integer, iNejmladsi As Integer
Dim Cas As Double, Rozdil As Double
Dim boVytvoreno As Boolean

'pokud je soubor jen pro čtení, přeskoč tvorbu zálohy
If ThisWorkbook.ReadOnly = True Then
MsgBox "Tento soubor je otevřen jen pro čtení, takže nebudu vytvářet zálohu"
Exit Sub
End If

'název tohoto souboru
strName = ThisWorkbook.Name
'odřezat příponu
strName = Left(strName, Len(strName) - 5)
'cesta, kam se budou ukládat zálohy
strPath = ThisWorkbook.Path & "\MojeVykazy\Zalohy\"

'kdybychom otevírali záložný soubor, ať se nic neděje
If Left(strName, 4) = "Zal_" Then Exit Sub

'nejdřív zkontrolujeme, jestli adresář pro zálohy existuje, pokud ne, tak ho vytvoř
If Dir(strPath, vbDirectory) = "" Then
MkDir strPath
End If

'teď zkontrolujeme, zdali zálohy existují. Pokud ne, tak je rovnou vytvoř
For i = 1 To n
strNazev = strPath & "Zal_" & strName & "_" & i & ".xlsm"
If Dir(strNazev) = "" Then
'nápis ve stavovém řádku
Application.DisplayStatusBar = True
Application.StatusBar = "Vytvářím soubor zálohy: " & "Zal_" & strName & "_" & i & ".xlsm"
'vytvoř číslovaný soubor zálohy
ThisWorkbook.SaveCopyAs strPath & "Zal_" & strName & "_" & i & ".xlsm"
boVytvoreno = True
End If
Next i

If boVytvoreno Then GoTo FiNito 'pokud jsi vytvářel nějaký chybějící soubor zálohy, tak není nutné pokračovat

dDatum_Max = Now()
dDatum_Min = 0

'nazev založního souboru bez indexu a přípony
strName = ThisWorkbook.Name
strName = "Zal_" & Left(strName, Len(strName) - 5)

'tento cyklus projede všechny očíslované záložné soubory a zjistí _
který je nejstarší a nejmladší
i = 1
Do
strNazev = strPath & strName & "_" & i & ".xlsm"
If Dir(strNazev) = "" Then Exit Do
dDatum = FileDateTime(strNazev)

If dDatum < dDatum_Max Then
If dDatum > dDatum_Min Then
dDatum_Min = dDatum
iNejmladsi = i
End If
dDatum_Max = dDatum
iNejstarsi = i
Else
If dDatum_Min < dDatum Then
dDatum_Min = dDatum
iNejmladsi = i
End If
End If
i = i + 1
Loop

'kdyby nebyl nalezen žádný takový soubor, dej hlášku
If i = 1 Then
MsgBox "na místě " & strPath & vbCr _
& " nebyly nalezeny soubory záloh"
Exit Sub
End If

'Nastavení minimálního intervalu zálohování 1 = 1 den
'porovnáme čas uložení nejmladšího a nynější čas
Cas = CDbl(FileDateTime(strPath & strName & "_" & iNejmladsi & ".xlsm"))
'zjisti rozdíl časů
Rozdil = Round(CDbl(Now) - Cas, 2)

'nápis ve stavovém řádku
Application.DisplayStatusBar = True
Application.StatusBar = "Poslední záloha byla uložena před " & 24 * Rozdil & " hod"

If Rozdil > sgInterval Then
'přepiš nejstarší zálohu
ThisWorkbook.SaveCopyAs strPath & strName & "_" & iNejstarsi & ".xlsm"
End If

FiNito:
'vrátime excelu kontrolu nad stavovým řádkem
Application.StatusBar = False
On Error GoTo 0

End Sub

Zaslat odpověď >

Nebyly zaslány žádné odpovědi.

Uživatelské menu

Nejste přihlášen(a)

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.