[VBScript] When did I log on/off?

The Australian federal government has brought in new laws which seem to require a return to the old days of clocking in at the beginning of the working day and clocking out at the end. As a contractor I don't think I'm going to notice a big difference ... if I want to get paid for the hours I work, then I fill out my timesheet appropriately.

If you aren't in the habit of keeping this kind of information, don't worry too much: Windows keeps a track of your login and logout in one of its Event Logs. Getting that information is fairly easy, if you know what you're looking for. Otherwise its like the proverbial needle in the haystack.

The script outputs into an Excel spreadsheet, the date of each logon in a separate column containing time of logon and logoff. Please note that the script was designed to query someone else's machine, and will likely need modification if you are trying to get your own data out of your own event log.

Here's the code.

As is often the case in my scripts, the preamble loads external code libraries. The former is a the standard library and the latter (see the end of the posting) a symbol table class, based on the Scripting.Dictionary object.

option explicit

Function GetEnv( strEnvVar )
    Dim oProcessEnvironment
    Dim sResult
    With CreateObject( "WScript.Shell" )
        GetEnv = .Environment( "PROCESS" )( UCase( strEnvVar ) )
    End With
End Function

Sub Include( scriptName )
    Dim sScript
    Dim oStream
    'on error resume next
    err.clear
    With CreateObject( "Scripting.FileSystemobject" )
        Set oStream = .OpenTextFile( scriptName )
    End With
    If Err.Number > 0 Then
        MsgBox "Could not open " & scriptName
        WScript.Quit
    End If
    Err.Clear
    sScript = oStream.ReadAll()
    oStream.Close
    ExecuteGlobal sScript
    If Err.Number <> 0 Then
        Die "Error in loaded script"
    End If
    On Error Goto 0
End Sub

Include "C:\Script\StandardLibrary.vbs"
Include "C:\Script\ClassSymTab.vbs"

Dim V
Set V = New Symtab

Next comes code to split up the event log's timestamp, followed by the routine to store logon date and logon and logoff times into spreadsheet cells.

function timesplit( sDateTime )
    timesplit = Left( sDateTime, 4 ) & "-" & Mid( sDateTime, 5, 2) & _
        "-" & Mid( sDateTime, 7, 2 ) & " " & Mid( sDateTime, 9, 2 ) & _
        ":" & Mid( sDateTime, 11, 2 ) & ":" & Mid( sDateTime, 13, 2 )
end function

Dim nECol
nEcol = 2

sub Excellent( dOn, dOff )
    oSheet.Cells( 1, nECol ).Value = DateValue( dOn )
    oSheet.Cells( 1, nECol ).Font.Bold = True
    oSheet.Cells( 2, nECol ).Value = TimeValue( dOn )
    oSheet.Cells( 3, nECol ).Value = TimeValue( dOff )
    oSheet.Columns(nECol).EntireColumn.AutoFit
    nECol = nECol + 1
end sub

Next comes the variable declarations. In retrospect the variables sComputer and sUser could have been Const rather than Dim. For that matter they could have been taken from the command line. Note the double backslash in the uUser variable: this is needed for where it occurs in the WMI call.

Const MAX_INSTANCE = 365

dim sComputer
Dim sUser
Dim oWMIService
dim cEvents
dim oEvent
Dim dLastDate
Dim aResults
Dim aRes
Dim n
Dim dLogin, dLogout
Dim aDates
Dim bFirst
Dim nInstance

sComputer = "THEMACHINE"
sUser = "THEDOMAIN\\theuser"

This is the core of the script: pointing WMI at sComputer and executing an SQL query against Win32_NTLogEvent. It asks for everything from the 'Security' Logfile where the EventCode matches a logon or a logoff and where the User matches sUser.

Set oWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
        sComputer & "\root\cimv2")
Set cEvents = oWMIService.ExecQuery _
    ("Select * from Win32_NTLogEvent " _
        & "Where Logfile = 'Security' And _
        (EventCode=528 Or EventCode=538) And _
        User='" & sUser & "'")

Then the script starts to do things with the list of events now stored in cEvents. First a Dictionary is loaded with logons as (zero, comma, TimeSplit of datestamp) and logoffs as (one, comma, TimeSplit of datestamp). The reason for this is that there may be more than one logon and logoff event for a given user during a working day. By storing the logon and logoff times in this way, the first "0" reference can be assumed to be the first logon off the day, and the last "1" can be assumed to be the last logoff of the day.

dLastDate = dbDate( Cdate( 0 ) )

For Each oEvent in cEvents
    V.Store IIF( oEvent.EventCode = 528, 0, 1 ) & "," & TimeSplit( oEvent.TimeWritten ), vbNullString
Next

From the Dictionary wrapper class the keys are extracted. A check is put in here to make sure that there are records to be reported.

aResults = V.Keys()
'MsgBox Join( aResults, vbNewLine )
If UBound( aResults ) < 0 Then
    MsgBox "No records found"
    WScript.Quit
End If

Next comes the Excel interactions. The ExcelStart and ExcelNewSheet macros are listed at the bottom of this posting.

Dim oRange
Dim oSelection

ExcelStart False
ExcelNewSheet

oSheet.Cells( 2, 1 ).Value = "Logon"
oSheet.Cells( 3, 1 ).Value = "Logoff"
Set oRange = oSheet.Range( "A2", "A3" )
oRange.Font.Bold = True

What follows is the guts of the Excel reporting. Despite the possibility of incorrect recording, the assumption is that the report will contain the first logon and the last logoff. If a logon occurs after the last logoff, it is discarded. The script is unable to cope with the situation where someone logs on today and logs off tomorrow.

Note that a check is made not to report more dates than MAX_INSTANCE, a limit that has not yet been encountered. AMax and AMin are listed at the bottom of the posting.

aRes = Split( aResults( 0 ), "," )
dLastDate = DateValue( aRes( 1 ) )
ReDim aDates( -1 )
n = 1
bFirst = True
nInstance = 0
Do While True
    aRes = Split( aResults( n ), "," )
    If DateValue( aRes( 1 ) ) <> dLastDate And bFirst = False Then
        dLogin = AMin( aDates )
        dLogout = AMax( aDates )
        Excellent dLogin, dLogout
        nInstance = nInstance + 1
        If nInstance >= MAX_INSTANCE Then
            Exit Do
        End If
        ReDim aDates( -1 )
        dLastDate = DateValue( aRes( 1 ) )
    Else
        bFirst = False
        AAdd aDates, aRes( 1 )
        n = n + 1
        IF n > UBound( aResults ) Then
            Exit Do
        End If
    End If
Loop

Set oWMIService = Nothing
Set cEvents = Nothing

Excel is left running with the results of the report. It's up to the user to save it, print it or whatever. To finish, the macros ExcelStart, ExcelNewSheet, AMax and AMin, and the ClassSymTab class as promised.

Dim oExcel

Sub ExcelStart( bHidden )
    Set oExcel = CreateObject("Excel.Application")
    If bHidden = True Then
        oExcel.Visible = False
        oExcel.Interactive = False
    Else
        oExcel.Visible = True
        oExcel.Interactive = True
    End If
End Sub

Dim oWorkbook
Dim oSheet

Sub ExcelNewSheet()
    Set oWorkbook = oExcel.Workbooks.Add()
    Set oSheet = oWorkbook.ActiveSheet
End Sub

Function AMax( aVec )
    Dim vTemp
    Dim vResult

    vResult = aVec( 0 )

    For Each vTemp in aVec
        If vTemp > vResult Then
            vResult = vTemp
        End If
    Next
    AMax = vResult
End Function

Function AMin ( aVec )
    Dim vTemp
    Dim vResult

    vResult = aVec( 0 )

    For Each vTemp in aVec
        If vTemp < vResult Then
            vResult = vTemp
        End If
    Next
    AMin = vResult
End Function

Class symtab
    private oHash
    private sSystemPrefix

    Private Sub Class_Initialize()
        Set oHash = CreateObject( "Scripting.Dictionary" )
        sSystemPrefix = "$"
    End Sub

    Private Sub Class_Terminate()
        Set oHash = Nothing
    End Sub

    Public Sub Store( sName, vValue )
        If oHash.Exists( sName ) Then
            oHash( sName ) = vValue
        Else
            oHash.Add sName, vValue
        End If
    End Sub

    Public Function Recall( sName )
        If oHash.Exists( sName ) Then
            Recall = oHash( sName )
        Else
            Recall = Null
        End If
    End Function

    Public Function Keys()
        Keys = oHash.Keys
    End Function
    
    Public Function SymList()
        Dim nCount
        Dim aResult
        Dim aKeys
        Dim aItems
        Dim i

        nCount = oHash.Count
        'WScript.Echo nCount
        ReDim aResult( nCount - 1 )
        aKeys = oHash.Keys
        aItems = oHash.Items

        For i = 0 To nCount - 1
            'aResult( 0, i ) = aKeys( i )
            'aResult( 1, i ) = aItems( i )
            aResult( i ) = aKeys( i ) & "^" & aItems( i )
        Next
        'WScript.Echo UBound( aResult )
        SymList = aResult
    End Function

    Public Function SymListText()
        Dim aList
        Dim sItem
        Dim i
        Dim sResult
        aList = SymList()
        For i = 0 To UBound( aList )
            sItem = Replace( aList( i ), "^", "=" )
            sResult = sResult & sItem & vbNewLine
        Next
        SymListText = sResult
    End Function

    Public Function IsSym( sName )
        IsSym = oHash.Exists( sName )
    End Function

    Public Sub StoreDup( sName, xValue )
        Dim i
        Dim sNewName
        sNewName = sName
        i = 1
        If IsSym( sNewName ) Then
            Do
                sNewName = sName & "$" & i
                If oHash.Exists( sNewName ) = False Then
                    Exit Do
                End If
                i = i + 1
            Loop
        End If

        'WScript.Echo "StoreDup", sNewName, xValue
        Store sNewName, xValue
    End Sub

    Public Sub Parse( sData, sSep )
        Dim aData
        Dim i
        Dim sLine
        Dim aLine
        Dim sKey
        Dim sValue

        aData = Split( sData, vbNewLine )
        For i  = 0 To UBound( aData )
            sLine = aData( i )
            IF sLine <> vbNullString Then
                aLine = Split( sLine, sSep )
                sKey = aLine( 0 )
                sValue = aLine( 1 )
                sKey = UCase( RTrim( RemoveSpaces( sKey ) ) )
                sValue = RTrim( sValue )
                Store sKey, sValue
            End If
        Next
    End Sub

    Public Sub Remove( sData )
        IF oHash.Exists( sData ) Then
            oHash.Remove sData
        End If
    End Sub

    Public Sub Clear()
        Dim aList
        Dim i
        Dim sLine
        Dim aLine
        aList = SymList()
        For i = 0 To UBound( aList )
            sLine = aList( i )
            aLine = Split( sLine, "^" )
            If BeginsWith( aLine( 0 ), sSystemPrefix, False ) = False Then
                Remove aLine( 0 )
            End If
        Next
    End Sub
End Class