' Shutdown7.vbs ' VBScript Shutdown 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 "## Shutdown 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