Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img
Ein Programm in der Programmiersprache A program in the programming language
vbScript
zur automatischen Generierung eines Backup-Protokolls in Form einer Excel-Tabelle for automatic generation of a backup-protocol in form of an excel-table

Das folgende vb-Script erzeugt automatisch ein Backup-Protokoll durch Einsammeln von Datum und Uhrzeit aller verfügbaren Backup-Protokolle und Eintragung der Daten in eine gemeinsame Excel-Datei, die nachher in alle Backups kopiert wird. Datum und Uhrzeit wird durch ein anderes vb-Script (siehe vorige Seite), welches von einem Langmeier-Backup-Auftrag gestartet wird, in eine Datei geschrieben, die vom selben Langmeier-Backup-Auftrag in die gewünschten Verzeichnisse der Original-Daten kopiert wird. Durch den Backup-Vorgang werden diese Dateien mitkopiert und danach wird Datum und Uhrzeit aus ihren Inhalten vom folgenden vb-Script eingesammelt und in das Backup-Protokoll eingetragen. Dann kann jederzeit von überall aus in die Excel-Datei Einblick genommen werden.

The following vb-Script generates automaticly a backup-protocol by picking-up date and clocktime out of all available backup-protocols and entering of data in a common excel-file, which is copied thereafter into all backups. Date and clocktime will be written by another vb-Script (see previous page), which is started by a Langmeier-Backup-task, by the same Langmeier-Backup-task into the desired folders of the original data. These files will be copied by the backup-procedure, together with the other backup data, and thereafter date and clocktime will be picked-up from their contents and entered into the backup-protocol. Then it can be taken anytime insight from everywhere into the excel-table.

Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist
The program ist tested before publication, but there can be given no guarantee, that it is free of errors
3. Aug. 2012 Aug 3rd 2012

' Update Backup-Protocol

Option Explicit

' Constants, Variables + Objects

Const ForReading=1, ForWriting=2 ' Constants
Dim fso, objexcel, objWorkbook ' Objects
Dim TmpText, DesiredDrive, DriveLetter, DAT, DateAndTime, SourceFileSpec ' Strings
Dim PathOfBackupProtocol, FileNameOfBackupProtocol, FileNameOfLastBackup, FileNameTemp ' Strings
Dim BF, row, col ' Numerics
Dim DesiredDriveList, BaseFolderList  ' Arrays
Public DriveList: ReDim DriveList(-1) ' C:\Drivename1

' Instantiations

Set fso = CreateObject("Scripting.FileSystemObject")
Set objexcel = CreateObject("Excel.application")

' User-Parameter-Settlings

ReadOut ' Causes Reset of TmpText
ReadIn "Drivename1,Drivename2,Drivename3,Drivename4,Drivename5"
DesiredDriveList = ReadOut ' causes handing over of TmpText in form of an Array and reset

ReadIn "TOTALARCHIVE\OLDDATA\,TOTALARCHIVE\ACTUALDATA\"
BaseFolderList = ReadOut

PathOfBackupProtocol = "c:\TOTALARCHIVE\ACTUALDATA\"
FileNameOfBackupProtocol = "Backup-Protocol.xlsx"
FileNameOfLastBackup = "LastBackup.txt"
FileNameTemp = "Temp.xlsx"
Set objWorkbook = objexcel.Workbooks.Open(PathOfBackupProtocol & FileNameOfBackupProtocol)

' Program

For Each DesiredDrive In DesiredDriveList
    DriveLetter = GetDriveLetterFromDriveName(DesiredDrive)
    If DriveLetter <> "" Then
        For BF = 0 To 1 ' BF = Nr of BasefolderMinus1
            DAT = PickOutDateFromFile(DriveLetter & BaseFolderList(BF) & FileNameOfLastBackup)
            DateAndTime = DAT
            If DAT <> "" Then
                DateAndTime = ReformatDateAndTime(DAT)
                row = 3 + BF: col = 3 + Asc(UCase(DriveLetter))-70
                objexcel.Cells(row,col).Value = DateAndTime
            End If
        Next
    End If
Next

DeleteFileIfAny PathOfBackupProtocol & FileNameTemp
objexcel.ActiveWorkbook.SaveAs(PathOfBackupProtocol & FileNameTemp)
objexcel.Quit
Set objexcel = Nothing
DeleteFileIfAny PathOfBackupProtocol & FileNameOfBackupProtocol
fso.MoveFile PathOfBackupProtocol & FileNameTemp, PathOfBackupProtocol & FileNameOfBackupProtocol

'        Copy Backup-Protocol to all available drives

For Each DesiredDrive In DesiredDriveList
    DriveLetter = GetDriveLetterFromDriveName(DesiredDrive)
    If DriveLetter <> "" Then
        SourceFileSpec = "d:\" & BaseFolderList(1) & FileNameOfBackupProtocol
        If fso.FileExists(SourceFileSpec) Then
            fso.CopyFile SourceFileSpec, DriveLetter & BaseFolderList(1), True
        End If
    End If
Next

' End of Program

' Procedures

Function ReadIn(ByVal AnyText)
    If TmpText <> "" Then TmpText = TmpText & ","
    TmpText = TmpText & AnyText
End Function

Function ReadOut
    ReadOut = Split(TmpText,","): TmpText = ""
End function

Function GetDriveLetterFromDriveName(AnyDriveName)
    Dim item: GetDriveLetterFromDriveName = ""
    If UBound(DriveList) = -1 Then CreateDriveList
    For Each item In DriveList
        If Mid(item,4) = AnyDriveName Then
            GetDriveLetterFromDriveName = Left(item,3): Exit For
        End If
    Next ' "C:\"
End Function

Sub CreateDriveList
    Dim dc, d: ReDim DriveList(-1)
    Set dc = fso.Drives
    For Each d In dc
        If d.IsReady Then
            If d.DriveType = 1 Or d.DriveType = 2 Then
                ReDim Preserve DriveList(UBound(DriveList)+1)
                DriveList(UBound(DriveList)) = d.DriveLetter & ":\" & d.VolumeName
            End If
        End If
    Next
End Sub

Function ReformatDateAndTime(AnyDateAndTime)
    '....+....1....+.."
    'yyyymmddhhmmss
    '20101105134628
    Dim  s, a, i: s = ""
    a = Array("",7,".",5,".",1,"",3," ",9,":",11)
    For i = 0 To UBound(a)-1 Step 2
        s = s & a(i) & Mid(AnyDateAndTime, a(i+1), 2)
    Next: ReformatDateAndTime = s
    '05.11.2010 13:46
End Function

Function PickOutDateFromFile (AnyFile)
    Dim DateAndTime, MyFile, LineText: DateAndTime = ""
    If (fso.FileExists(AnyFile)) Then
        Set MyFile = fso.OpenTextFile(AnyFile, ForReading)
        Do While MyFile.AtEndOfStream = False
            LineText = MyFile.ReadLine
            DateAndTime = ExtractDateAndTime(LineText)
            If DateAndTime <> "" Then Exit Do
        Loop
        MyFile.Close
    End If
    PickOutDateFromFile = DateAndTime
End Function

' Extract Date and Time

'        Time of last backup :
'        Date and Time: 29.02.2012 23:59:59

'        AnyText = "Date and Time: 29.02.2012 23:59:59"

Function ExtractDateAndTime(AnyText)
    Dim TheDate, TheTime, Period, xDate, xTime, DateList, TimeList
    Dim x, TimeOK, limit, leapdays, yy, mm, Ptr
    ExtractDateAndTime = ""
    TheDate = ExtractDate(AnyText): TheTime = ExtractTime(AnyText)
    ' Check if Valid Date- and Time-Specification
    If TheDate <> "" And TheTime <> "" Then
        DateList = Split(TheDate,"."): x = DateList(2): DateList(2)= DateList(0): DateList(0)= x
        TimeList = Split(TheTime,":"): TimeOK = True
        leapdays = Array(3,0,3,2,3,2,3,3,2,3,2,3)
        yy = Eval(DateList(0)): mm = Eval(DateList(1))
        If mm > 12 Then mm = 12
        If mm < 1 Then mm = 1
        If yy/4 - Int(yy/4) = 0 Then leapdays(1) = 1
        If yy/100 - Int(yy/100) = 0 Then leapdays(1) = 0
        limit = Array(1900,2099,0,23,1,12,1,59,1,28+leapdays(mm-1),1,59)
        For Period = 0 To 2: Ptr = 4 * Period
            xDate = Eval(DateList(Period)): xTime = Eval(TimeList(Period))
            If xDate < limit(Ptr) Or xDate > limit(Ptr+1) Then TimeOK = False: Exit For
            If xTime < limit(Ptr+2) Or xTime > limit(Ptr+3) Then TimeOK = False: Exit For
        Next
        If TimeOK Then
            TheDate = Join (DateList,""): TheTime = Replace (TheTime,":","")
            ExtractDateAndTime = TheDate & TheTime
        End If
    End If
End Function

Function ExtractDate(AnyText)
    ExtractDate = ExtractDateByMask(AnyText, "##.##.####")
    If ExtractDate = "" Then
        ExtractDate = ExtractDateByMask(AnyText, "#.##.####")
    End If
End Function

Function ExtractDateByMask(AnyText, Mask)
    Dim Pos: ExtractDateByMask = ""
    Pos = InStr(ReplaceAllFigures (" " & AnyText & " "), " " & Mask & " ")
    If Pos = 0 Then Exit Function
    If Mask = "#.##.####" Then ExtractDateByMask = "0"
    ExtractDateByMask = ExtractDateByMask & Mid(AnyText, Pos, Len(Mask))
End Function

Function ReplaceAllFigures (ByVal AnyString)
    Dim i
    For i = 0 To 9
        AnyString = Replace(AnyString,CStr(i),"#")
    Next
    ReplaceAllFigures = AnyString
End Function

Function ReplacePerPos(AnyExpression, AnyPos1, AnyPos2, AnyReplacewith)
    '              Pos1    Pos2
    '               |       |
    '....+....1....+....2....+....3....+....4
    Dim L1, L2: L1 = Len(AnyExpression): L2 = Len(AnyReplacewith)
    ReplacePerPos = AnyExpression
    If AnyExpression = "" Or AnyPos1 > L1 Or AnyPos2 < 1 Or AnyPos1 > AnyPos2 Then Exit Function
    If AnyPos1 < 1 Then AnyPos1 = 1
    If AnyPos2 > L1 Then AnyPos2 = L1
    ReplacePerPos = Left(AnyExpression, AnyPos1 - 1) & AnyReplacewith & Mid(AnyExpression, AnyPos2 + 1)
End Function

Function ExtractTime(ByVal AnyText)
    Dim Mask, Pos: Mask = " ##:##:## ": ExtractTime = ""
    Pos = InStr(ReplaceAllFigures (" " & AnyText & " "), Mask)
    If Pos = 0 Then Exit Function
    ExtractTime = Mid(AnyText, Pos, Len(Mask) - 2)
End Function

'End of Extract Date and Time

Sub DeleteFileIfAny (AnyFileSpec)
    If fso.FileExists(AnyFileSpec) Then fso.DeleteFile(AnyFileSpec)
End Sub

' End of Procedures