' Logoff7.vbs
' VBScript Logoff script to enforce one logon session per user.
'
' ----------------------------------------------------------------------
' Copyright (c) 2010 Richard L. Mueller
' Hilltop Lab web site - http://www.rlmueller.net
' Version 1.0 - May 29, 2010
' Version 1.1 - June 3, 2010
'
' You have a royalty-free right to use, modify, reproduce, and
' distribute this script file in any way you find useful, provided that
' you agree that the copyright owner above has no warranty, obligations,
' or liability for such use.

Option Explicit

Dim objFSO, objNetwork, strComputer, strComputerEncoded
Dim strShare, strFlagFile, objFile, strLine, objFolder
Dim strHexValue, strUserEncoded, objSysinfo, strUserDN, objUser
Dim strShare2, objErrorLog, strErrorLog, intCount

Const B64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Const ForReading = 1
Const ForAppending = 8
Const OpenAsASCII = 0
Const CreateIfNotExist = True

' Specify shared folder.
strShare = "\\MyServer\MyShare\Logs"

' Specify alternate folder if the first is unavailable.
strShare2 = "\\MyServer2\MyShare\Logs"

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objNetwork = CreateObject("Wscript.Network")

' Retrieve user and computer information.
Set objSysInfo = CreateObject("ADSystemInfo")
strUserDN = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUserDN)
strComputer = objNetwork.ComputerName

' Base64 encode computer name and user GUID.
strHexValue = TextToHex(strComputer)
strComputerEncoded = HexToBase64(strHexValue)

strHexValue = TextToHex(objUser.GUID)
strUserEncoded = HexToBase64(strHexValue)
strUserEncoded = Replace(strUserEncoded, "=", "")

' Create flag file based on encoded user GUID.
strFlagFile = strShare & "\" & strUserEncoded & ".log"

' Check if flag file exists for this user.
If (objFSO.FileExists(strFlagFile) = True) Then
    ' Read encoded computer name from the flag file.
    Set objFile = objFSO.OpenTextFile(strFlagFile, ForReading)
    strLine = objFile.ReadLine
    objFile.Close
    ' Check encoded computer name.
    If (strLine = strComputerEncoded) Then
        ' Delete the file.
        objFSO.DeleteFile strFlagFile
    End If
    Wscript.Quit
End If

' No flag file found for this user. Make sure share is available.
On Error Resume Next
Set objFolder = objFSO.GetFolder(strShare)
If (Err.Number <> 0) Then
    On Error GoTo 0
    ' Log error to alternate location.
    strErrorLog = strShare2 & "\Error.log"
    On Error Resume Next
    Set objErrorLog = objFSO.OpenTextFile(strErrorLog, _
        ForAppending, CreateIfNotExist, OpenAsASCII)
    If (Err.Number = 0) Then
        On Error GoTo 0
        ' Make trhee attempts to write, in case many users are affected.
        intCount = 1
        Do Until intCount = 3
            On Error Resume Next
            objErrorLog.WriteLine "## Logoff Error" _
                & vbCrLf & "Time: " & CStr(Now()) _
                & vbCrLf & "Share unavailable: " & strShare _
                & vbCrLf & "User: " & strUserDN _
                & vbCrLf & "Computer: " & strComputer _
                & vbCrLf & "Flag file: " & strFlagFile
            If (Err.Number = 0) Then
                On Error GoTo 0
                Exit Do
            Else
                Err.Clear
                intCount = intCount + 1
                Wscript.Sleep 200
            End If
            On Error Goto 0
        Loop
        objErrorLog.Close
    End If
End If
On Error GoTo 0

Function TextToHex(ByVal strText)
    ' Function to convert a text string into a string of hexadecimal bytes.
    Dim strChar, k

    TextToHex = ""
    For k = 1 To Len(strText)
        strChar = Mid(strText, k, 1)
        TextToHex = TextToHex & Hex(Asc(strChar))
    Next
End Function

Function HexToBase64(ByVal strHex)
    ' Function to convert a hex string into a base64 encoded string.
    ' Constant B64 has global scope.
    Dim lngValue, lngTemp, lngChar, intLen, k, j, strWord, str64, intTerm

    intLen = Len(strHex)

    ' Pad with zeros to multiple of 3 bytes.
    intTerm = intLen Mod 6
    If (intTerm = 4) Then
        strHex = strHex & "00"
        intLen = intLen + 2
    End If
    If (intTerm = 2) Then
        strHex = strHex & "0000"
        intLen = intLen + 4
    End If

    ' Parse into groups of 3 hex bytes.
    j = 0
    strWord = ""
    HexToBase64 = ""
    For k = 1 To intLen Step 2
        j = j + 1
        strWord = strWord & Mid(strHex, k, 2)
        If (j = 3) Then
            ' Convert 3 8-bit bytes into 4 6-bit characters.
            lngValue = CCur("&H" & strWord)

            lngTemp = Fix(lngValue / 64)
            lngChar = lngValue - (64 * lngTemp)
            str64 = Mid(B64, lngChar + 1, 1)
            lngValue = lngTemp

            lngTemp = Fix(lngValue / 64)
            lngChar = lngValue - (64 * lngTemp)
            str64 = Mid(B64, lngChar + 1, 1) & str64
            lngValue = lngTemp

            lngTemp = Fix(lngValue / 64)
            lngChar = lngValue - (64 * lngTemp)
            str64 = Mid(B64, lngChar + 1, 1) & str64

            str64 = Mid(B64, lngTemp + 1, 1) & str64

            HexToBase64 = HexToBase64 & str64
            j = 0
            strWord = ""
        End If
    Next
    ' Account for padding.
    If (intTerm = 4) Then
        HexToBase64 = Left(HexToBase64, Len(HexToBase64) - 1) & "="
    End If
    If (intTerm = 2) Then
        HexToBase64 = Left(HexToBase64, Len(HexToBase64) - 2) & "=="
    End If

End Function