Attribute VB_Name = "Module1"

Public wws_server As CacheObject.Factory
Public ar_server As CacheObject.Factory
Public mbackuptime, mlastbackup, logpath, dvdpath

Declare Sub Sleep Lib "Kernel32" (ByVal time As Long)


Sub backup()
Dim obj As Object

'tstart

On Error GoTo err:

'Verwendete Dateien
'
'Auf DVD:
'
'   dvdid.dat                   DVD-Kennung
'   dokverz.zip, dokverz.bat    Verzeichnis der Dokumente
'   dok.zip                     Gezippte Dokumentdaten
'       id999999.ext    Dokumentdatei
'       id.dat          Verzeichnisdatei je dok.zip
'
'In temp-Verzeichnis:
'
'   id999999.ext                Dokumentdatei(.pdf oder .tif)
'   id.dat                      Verzeichnisdatei je dok.zip
'
'In log-Verzeichnis
'   dokverz.dat, dokverz.bat    Verzeichnis der Dokumente für DVD


archivsv.list1.ClearList

'Wochentagstabelle aufbauen
Dim wkday(7) As String
wkday(1) = "FR"
wkday(2) = "MO"
wkday(3) = "DI"
wkday(4) = "MI"
wkday(5) = "DO"
wkday(6) = "FR"
wkday(7) = "FR"
'----------------------------------

date1 = Date

'Parameterdaten lesen
Set para = ar_server.OpenId("AR.Para", 1)
aktdvdid = para.aktdvdid
dvdpath = para.dvdpath
tmppath = para.Temppath
Call para.sys_Close
Set para = Nothing
'-------------------------------------------------------------------------------

'DVD-Kennung von DVD lesen
file = dvdpath + "\dvdid.dat"
dvdid = ""
dvdlastid = ""
On Error GoTo err1:
Open file For Input As #1
Input #1, dvdid
Input #1, dvdlastid
dvdlastid = Val(dvdlastid)
err1:
Resume Next
Close #1
'-------------------------------------------------------------------------------

On Error GoTo err:

'DVD-Kennung überprüfen
If dvdid = "" Then
   Set obj = ar_server.Static("GUI.EMail")
   'erg = obj.Send("administrator@nadlinger.at", "edv@nadlinger.at", "Archivserver", "DVD nicht identifizierbar")
   MsgBox "DvD nicht identifizierbar", vbCritical, "Archivserver"
   Set obj = Nothing
   Exit Sub
End If

If aktdvdid <> Left(dvdid, 6) Then
   Set obj = ar_server.Static("GUI.EMail")
   'erg = obj.Send("administrator@nadlinger.at", "edv@nadlinger.at", "Archivserver", "Falsche DVD eingelegt")
   MsgBox "Falsche DvD eingelegt", vbCritical, "Archivserver"
   Set obj = Nothing
   Exit Sub
End If

If wkday(Weekday(Date)) <> Mid(dvdid, 7, 2) Then
   Set obj = ar_server.Static("GUI.EMail")
   'erg = obj.Send("administrator@nadlinger.at", "edv@nadlinger.at", "Archivserver", "DVD für falschen Wochentag eingelegt")
   MsgBox "DvD für falschen Wochentag eingelegt", vbCritical, "Archivserver"
   Set obj = Nothing
   Exit Sub
End If
'--------------------------------------------------------------------------------

'Kommunikation stoppen
archivsv.Timer1 = False
archivsv.back.Enabled = False
archivsv.end.Enabled = False
DoEvents
'-----------------------------------


archivsv.list1.InsertItem "Sicherungsvorgang starten", 0
If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1

Dim dok As CacheObject.ObjInstance
Set obj = ar_server.Static("AR.Dokumente")
lastid = obj.lastid

'Neue Dokumente in tmp-Verzeichnis speichern &
'Logdatei für DVD/Dokumentdatei erstellen

lastid1 = 0
datsw = False
Open tmppath + "\id.dat" For Output As #1
Write #1, Date
Write #1, time
For id = dvdlastid + 1 To lastid
   lastid1 = id
   datsw = True
   beleg = bildinformation(id, tmppath)
   Write #1, id, beleg
Next
'-------------------------------------------------------------------------------

'Backupinformation der Dokumente setzen
If datsw Then
    archivsv.list1.InsertItem "BackupInformation erstellen", 0
    If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
    erg = obj.SetBackupInfo(dvdid, dvdlastid + 1, lastid1)
    If erg = "" Then
        MsgBox "Fehler beim setzen der BackupInforamtion", vbCritical, "Archivserver"
        GoTo ende:
    End If
End If
'-------------------------------------------------------------------------------



'Backupcopy der Logdatei im Logbereich Archivserver erstellen
fileprot = "ar_" + Format(Year(Date), "####") + Format(Month(Date), "0#") + Format(Day(Date), "0#") + "_" + Format(Hour(time), "0#") + Format(Minute(time), "0#") + Format(Second(time), "0#") + ".zip"
On Error Resume Next
FileCopy logpath + "\dokverz.dat", logpath + "\dokverz.bak"
On Error GoTo 0
Open logpath + "\dokverz.dat" For Append As #2
If lastid1 > 0 Then
   Write #2, dvdlastid + 1, lastid1, fileprot
   verzsw = True
End If
'--------------------------------------------------------------------------------

'Datei 1 = Logdatei in temp für DVD
'Datei 2 = Logdatei auf Archivserver


'Geänderte(exclusive neue) Dokumente in temp-Verzeichnis kopieren
Dim rs As CacheObject.ResultSet
Set rs = ar_server.ResultSet("AR.Dirty", "Dirty")
rs.Execute (wkday(Weekday(date1)))
While rs.Next()
   id = rs.GetData(1)
   If (id < (dvdlastid + 1)) Or (id > lastid1) Then
        datsw = True
        verzsw = True
        beleg = bildinformation(id, tmppath)
        obj.SetBackupInfo dvdid, id, id
        Write #1, id, beleg
        Write #2, id, id, fileprot
    End If
Wend
rs.Close
Close #1
Close #2
'-------------------------------------------------------------------------------

'Verzeichnisdatei auf DVD in  Backup-Datei kopieren, aktuelle Log-Datei zippen und
'auf DVD kopieren

If verzsw Then
    archivsv.list1.InsertItem "Verzeichnisdatei Zippen und auf DVD schreiben", 0
    If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
    DoEvents
    On Error Resume Next
    FileCopy dvdpath + "\dokverz.zip", dvdpath + "\dokverz.bak"
    Kill dvdpath + "\dokverz.zip"
    On Error GoTo err:
    
    archivsv.zip1.ZIPFile = tmppath + "\dokverz.zip"
    archivsv.zip1.ZIPString = ""
    archivsv.zip1.ItemList = logpath + "\dokverz.dat"
    On Error Resume Next
    archivsv.zip1.RecurseFlag = False
    archivsv.zip1.CompressionFactor = 9
    archivsv.zip1.NoDirectoryNamesFlag = True
    archivsv.zip1.NoDirectoryEntriesFlag = True
    archivsv.zip1.ActionDZ = 4
    On Error GoTo err:
    FileCopy tmppath + "\dokverz.zip", dvdpath + "\dokverz.zip"
End If


'in Temp gespeicherte Dokumentdaten zippen und auf DVD schreiben
If datsw Then
    archivsv.list1.InsertItem "Dateien komprimieren", 0
    If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
    DoEvents
    
    archivsv.zip1.ZIPFile = tmppath + "\dok.zip"
    archivsv.zip1.ZIPString = ""
    archivsv.zip1.ItemList = tmppath + "\*.pdf " + tmppath + "\*.tif " + tmppath + "\id.dat"
    archivsv.zip1.CompressionFactor = 9
    archivsv.zip1.NoDirectoryNamesFlag = True
    archivsv.zip1.NoDirectoryEntriesFlag = True
    archivsv.zip1.MinorStatusFlag = True
    On Error Resume Next
    archivsv.zip1.ActionDZ = 4
    
    On Error GoTo err:
    file = dvdpath + "\" + fileprot
    archivsv.list1.InsertItem "Tagesdatei " + file + " auf DVD schreiben", 0
    If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
    FileCopy tmppath + "\dok.zip", file
    
    SetAttr file, vbReadOnly
    On Error Resume Next
    Kill tmppath + "\dok.zip"
    On Error GoTo err:
       
    archivsv.list1.InsertItem "Neue DVD-Id erstellen", 0
    If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
 Else
    archivsv.list1.InsertItem "Keine Bilddaten zum Sichern vorhanden", 0
    If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
    
    GoTo ende:
End If
'---------------------------------------------------------------------------------

'neue DVD-id erstellen
file = dvdpath + "\dvdid.dat"
If lastid1 > 0 Then
    Open file For Output As #1
    Write #1, dvdid
    Write #1, lastid1
    Close #1
End If
'---------------------------------------------------------------------------------

'Tagesänderungsdatei (dirty) rücksetzen
archivsv.list1.InsertItem "Tagesänderungsdatei rücksetzen", 0
If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
DoEvents
Set obj = ar_server.Static("AR.Dirty")
obj.KillDay (wkday(Weekday(date1)))
Set obj = Nothing
'---------------------------------------------------------------------------------

'Letztes Sicherungsdatum in DVD-Daten setzen
Set obj = ar_server.Static("AR.DvD")
obj.SetLastbackup (dvdid)
Set obj = Nothing

'tcommit

ende:

'Datenbankverbindungen beenden & temporäre Dateien löschen
Set para = ar_server.OpenId("AR.Para", 1)
para.lastbackup = Date
mlastbackup = Date
Call para.sys_Save
Call para.sys_Close
Set para = Nothing


archivsv.list1.InsertItem "Temporäre Dateien löschen", 0
If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
Kill tmppath + "\*.*"

archivsv.list1.InsertItem "Sicherungsvorgang beendet", 0
If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1

archivsv.back.Enabled = True
archivsv.end.Enabled = True
archivsv.Timer1 = True
Exit Sub

err:
MsgBox err.Source, vbCritical, "Error"
'trollback

archivsv.list1.InsertItem "Temporäre Dateien löschen", 0
If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
Kill tmppath + "\*.*"

archivsv.list1.InsertItem "Sicherungsvorgang beendet", 0
If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1

archivsv.back.Enabled = True
archivsv.end.Enabled = True
archivsv.Timer1 = True


End Sub


Function bildinformation(ByVal id As Integer, ByVal tmppath As String) As String
   Set dok = ar_server.OpenId("AR.Dokumente", id)
   archivsv.list1.InsertItem "Dokument ID=" + Format(id) + " Bildinformation verarbeiten", 0
   If archivsv.list1.ListCount > 100 Then archivsv.list1.RemoveItem archivsv.list1.ListCount - 1
   
   bildinformation = dok.belart + dok.belnr
   DoEvents
   
   ext = dok.GetDoktyp(Format(id))
   If ext <> "" Then
    file = "id" + Format(id, "0000000#") + "." + ext
    dok.dok.FileWrite (tmppath + "\" + file)
   End If
   Call dok.sys_Close
   Set dok = Nothing
End Function

Function Piece(ByVal S As String, ByVal tr As String, ByVal N As Integer) As String
    n1 = 1
    R = ""
    For i = 1 To Len(S)
        c = Mid$(S, i, 1)
        If c = tr Then
           n1 = n1 + 1
           If n1 = N + 1 Then Exit For
          Else
           If N = n1 Then R = R & c
        End If
    Next
    Piece = R
End Function

