' Startup7.vbs
' VBScript Startup 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
' Version 1.2 - March 25, 2011 - Define constants.
'
' 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
Dim strComputerEncoded, strShare, strComputer, strHexValue
Dim objFolder, objFiles, strFile, objStream, strLine
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 NetBIOS name of local computer.
strComputer = objNetwork.ComputerName

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

' Bind to shared folder.
On Error Resume Next
Set objFolder = objFSO.GetFolder(strShare)
If (Err.Number = 0) Then
    On Error GoTo 0
    ' Enumerate all flag files in the folder.
    Set objFiles = objFolder.Files
    For Each strFile In objFiles
        ' Delete all files for this computer.
        Set objStream = objFSO.OpenTextFile(strFile, ForReading)
        strLine = objStream.ReadLine
        objStream.Close
        If (strLine = strComputerEncoded) Then
            objFSO.DeleteFile strFile
        End if
    Next
Else
    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 three attempts to write, in case many users are affected.
        intCount = 1
        Do Until intCount = 3
            On Error Resume Next
            objErrorLog.WriteLine "## Startup Error" _
                & vbCrLf & "Time: " & CStr(Now()) _
                & vbCrLf & "Share unavailable: " & strShare _
                & vbCrLf & "Computer: " & strComputer
            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

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