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
zum Erzeugen, Lesen und Schreiben einer Excel-Tabelle to create, read, write an 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
16. März 2016 March 16th 2016
' Program in vbScript
' Functions which are used in Script, 
' but not shown here can be found on others of my websites
' for example FiE means FileExist, Ubd means UBound, PUSH etc
' the program is running properly, but the code here not consequently
' shows all details.
' if Excel-table does not exist, the program creates a new one
' Sub ExcelUpdateTable seeks in an Excel-file in the first col the items,
' which are given in LastBackup and overwrites cells in second and third col
' with nowtime and runtime
' in case no item found all is written at the end of the table
' Dummy is a constant, if Dummy is True then no hard-disk operation is done.

Sub ExcelUpdateTable(LastBackup, rTime, fSpec)
    If Not FiE(fSpec) Then ExcelCreateTable Tasks, fSpec
    If Not FiE(fSpec) Then _
        PUSH ErrMsg, "Excel-file " & qo(fso.GetFileName(fSpec)) & " not found": Exit Sub
    Dim  Table: Table = ExcelGetTable(fSpec): If Ubd(Table) < 0 Then Exit Sub
    ExcelSortMsgIntoTable LastBackup, Table, rTime, fSpec
End Sub

Sub ExcelCreateTable(xTable, fSpec): Dim HeadCells, col, row, item
    HeadCells = Split("Menu Items,Time of last backup,Runtime",",")
    With objExcel: col = 0
        .Visible = False 'zeigt Excel nicht an, startet im Hintergrund
        .Workbooks.Add
        For Each item In HeadCells: INC col: .Cells(1, col).Value = item: Next: row = 1
        For Each item In Profiles: INC row: .Cells(row, 1).Value = item: Next
        .ActiveWorkbook.SaveAs(fSpec)
    End With
End Sub

Function ExcelGetTable(fSpec): ExcelGetTable = A0
    Dim objSheet, row, col, aRows, aCols, item
    With objExcel:      .Workbooks.Open fSpec
        Set objSheet =  .ActiveWorkbook.Worksheets(1)
        row = 1: aRows = A0
        With objSheet
            Do: INC row: If row > Excel_RowsMax Then Exit Do
                col = 1: aCols = A0
                item = .Cells(row,col).Value
                If item = "" Then Exit Do
                PUSH aCols, item            
                Do: INC col: If col > Excel_ColsMax Then Exit Do
                    item = .Cells(row,col).Value
                    If item = "" Then Exit Do
                    PUSH aCols, item
                Loop: If col <= Excel_ColsMax Then PUSH aRows, Join(aCols, ",")
            Loop:   
        End With:   .Application.DisplayAlerts = False
                    .ActiveWorkbook.Close
    End With:       ExcelGetTable = aRows
End Function

Sub ExcelSortMsgIntoTable(LastBackup, xTable, rTime, fSpec): Dim objSheet, item, Pos, t
    With objExcel:      .Workbooks.Open fSpec
        Set objSheet =  .ActiveWorkbook.Worksheets(1)
        With objSheet
            For Each item In LastBackup
                Pos = FIND(xTable, item, ",", 1): t = GetNowTime
                If Pos < 0 Then
                        PUSH xTable, Join(Array(item, t), ",")
                        .Cells(Ubd(xTable)+2,1).Value = item
                        If Not Dummy Then
                            .Cells(Ubd(xTable)+2,2).Value = t
                            .Cells(Ubd(xTable)+2,3).Value = rTime
                        End If
                Else:   If Not Dummy Then 
                            .Cells(Pos+2,2).Value = t
                            .Cells(Pos+2,3).Value = rTime
                        End If
                End If
            Next
        End With:   .Application.DisplayAlerts = False
                    .ActiveWorkbook.SaveAs fSpec
                    .ActiveWorkbook.Close
    End With
End Sub