Countdown Dialog box
I use Marimba and do not like their Reboot option. Essentailly if your application requires a Reboot, a screen pops with a Yes/No option.
I want to create my own Reboot message similiar to what WSUS has, in which a dialog box pops up and gives you options to reboot now or 1-4 hours later. If it has no response, then it reboots automatically after a set time I set.
Does anybody know if there is something out there like that I could use and modify to my needs. Thanks.
I want to create my own Reboot message similiar to what WSUS has, in which a dialog box pops up and gives you options to reboot now or 1-4 hours later. If it has no response, then it reboots automatically after a set time I set.
Does anybody know if there is something out there like that I could use and modify to my needs. Thanks.
0 Comments
[ + ] Show comments
Answers (5)
Please log in to answer
Posted by:
anonymous_9363
14 years ago
Here's an HTA I built in a rush for a client recently. You can obviously edit the various bits and bobs (e.g. the timeout and logo picture file) to suit yourself. The flow is a little convulted, but that's because I pressed working routines into service and used another working script as a shell. Anyway, knock yourself out...
<!DOCTYPE HTML PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd>
<HTML xmlns:yCode>
<TITLE>Scheduled shutdown</TITLE>
<HTA:APPLICATION
ID = "DoShutdown"
APPLICATIONNAME = "DoShutdown"
BORDER = "None"
BORDERSTYLE = "Normal"
CAPTION = "Yes"
CONTEXTMENU = "No"
INNERBORDER = "Yes"
MAXIMIZEBUTTON = "No"
MINIMIZEBUTTON = "No"
NAVIGABLE = "No"
SCROLL = "No"
SCROLLFLAT = "Yes"
SELECTION = "No"
SHOWINTASKBAR = "No"
SINGLEINSTANCE = "Yes"
SYSMENU = "No"
>
<HEAD>
<STYLE>
HTML, BODY
{
margin: 0;
padding: 0;
line-height: 1.5em;
font-size: 87%;
font-family: Verdana, Arial, Helvetica, sans-serif;
}
#top_body
{
clear: both;
margin: 20px 0 0 0;
text-align: center;
}
#top_body p
{
margin: 20px 0 0 0;
font-style: italic;
}
H1
{
color:#FF0000;
font-weight: bold;
text-transform: uppercase;
font-family: "Arial Narrow", Arial, Helvetica, sans-serif;
font-size: 3em; margin: 0 15px 0 0;
letter-spacing: -.05em;
}
H2
{
color: #4e4a4e;
font-weight: bold;
font-size: 1.4em;
margin: 15px 0 0 0;
}
INPUT
{
font-family: tahoma;
font-size: 18pt;
}
</STYLE>
<SCRIPT LANGUAGE="VBScript">
Public intReturn
Public objFSO
Public objWSHShell
Public objWSHShellApp
Public strArgument
Public strHTA
Public strHTAPath
Public strAppRootFolder
Public strCommandLine
Public intSlashPos
Public intHTANamePos
Public intSpacePos
Public strHours
Public strMinutes
Public strSeconds
Public datCountdownStartedTime
Public datExecutionTime
Public datCurrentTime
Public datRemainingTime
Public strCountdownStartedTime
Public strExecutionTime
Public strCurrentTime
Public strRemainingTime
Public intHours
Public intMinutes
Public intSeconds
Public intTimerID
Public strRestartType
Public strHeaderText
Public strRestartText
Const intWindowWidth = 550
Const intWindowHeight = 410
Const WMI_Shutdown_LogOff = 0
Const WMI_Shutdown_LogOffForced = 4
Const WMI_Shutdown_PowerOff = 8
Const WMI_Shutdown_PowerOffForced = 12
Const WMI_Shutdown_Reboot = 2
Const WMI_Shutdown_RebootForced = 6
Const WMI_Shutdown_Shutdown = 1
Const WMI_Shutdown_ShutdownForced = 5
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWSHShell = CreateObject("WScript.Shell")
Set objWSHShellApp = CreateObject("Shell.Application")
'// Set default timeout for 5 minutes
intHours = 0
intMinutes = 5
intSeconds = 0
'// Set default shutdown type
strRestartType = "RF"
intShutdownFlag = WMI_Shutdown_RebootForced
strRestartText = "restarted"
strHeaderText = "Scheduled restart"
Sub Window_Onload
Dim blnShow
Dim blnMiniseAllOpenWindows
Dim objFileHTA
Dim blnResult_Window
Dim intCountColon
Dim intCountSpace
strCommandLine = Trim(DoShutdown.CommandLine)
blnMiniseAllOpenWindows = True
'// Ditch the stupid quotes which MS has decreed will surround the name
'// even when there are no spaces in ANY folder name!
strCommandLine = Replace(strCommandLine, Chr(34), "")
'// Bizarrely, if an argument is passed to an HTA and we remove the quote marks,
'// we get an extra space character!
If InStr(strCommandLine, " ") > 0 Then
strCommandLine = Replace(strCommandLine, " ", " ")
End If
'// Whatever happens, the command line will have a backslash in it
intSlashPos = InStrRev(strCommandLine, "\")
intHTANamePos = InStr(UCase(strCommandLine), ".HTA")
intSpacePos = InStr(UCase(strCommandLine), " ")
If intHTANamePos < intSpacePos Then
'// The HTA was launched with argument(s). How many?
Call ParseArguments
Else
Set objFileHTA = objFSO.GetFile(strCommandLine)
strHTA = objFileHTA.Name
Set objFileHTA = Nothing
End If
Set objFileHTA = objFSO.GetFile(strHTA)
strHTA = objFileHTA.Name
strHTAPath = objFileHTA.ParentFolder.Path
Call ResizeWindow(intWindowWidth, intWindowHeight, blnShow)
Call CentreWindow(intWindowWidth, intWindowHeight, blnShow)
spanHeader.InnerText = strHeaderText
spanRestartText.InnerText = strRestartText
spanCountdownStartedPrompt.InnerText = "Countdown Started:"
spanExecutionTimePrompt.InnerText = "Execution Time:"
spanCurrentTimePrompt.InnerText = "Current Time:"
spanRemainingTimePrompt.InnerText = "Remaining Time:"
Call CalculateTimeout
Call CheckCountdown(blnMiniseAllOpenWindows, intHours,intMinutes,intSeconds)
End Sub
Sub ParseArguments
Dim blnResult_Parse
Dim intCountColon
Dim intCountSpace
Dim strArgument1
Dim strArgument2
strArgument = ""
strArgument1 = ""
strArgument2 = ""
blnResult_Window = GetSubstringCount(Chr(32), strCommandLine, True, intCountSpace)
If intCountSpace = 0 Then
strHTA = strCommandLine
Exit Sub
ElseIf intCountSpace = 1 Then
strHTA = Split(strCommandLine, Chr(32))(0)
strArgument1 = Split(strCommandLine, Chr(32))(1)
ElseIf intCountSpace = 2 Then
strHTA = Split(strCommandLine, Chr(32))(0)
strArgument1 = Split(strCommandLine, Chr(32))(1)
strArgument2 = Split(strCommandLine, Chr(32))(2)
Else
'// Twat...
End If
If InStr(strArgument1, ":") > 0 Then
blnResult_Parse = GetSubstringCount(":", strArgument1, True, intCountColon)
If (intCountColon > 2) Or (intCountColon < 1) Then
'// Twat...
Else
strHours = Split(strArgument1, ":")(0)
strMinutes = Split(strArgument1, ":")(1)
strSeconds = Split(strArgument1, ":")(2)
End If
End If
If Len(strArgument2) > 0 Then
Select Case strArgument2
Case "L"
intShutdownFlag = WMI_Shutdown_LogOff
strHeaderText = "Scheduled log-off"
strRestartText = "logged off"
Case "LF"
intShutdownFlag = WMI_Shutdown_LogOffForced
strHeaderText = "Scheduled log-off"
strRestartText = "forcibly logged off"
Case "P"
strHeaderText = "Scheduled power-off"
intShutdownFlag = WMI_Shutdown_PowerOff
strRestartText = "powered off"
Case "PF"
strHeaderText = "Scheduled power-off"
intShutdownFlag = WMI_Shutdown_PowerOffForced
strRestartText = "forcibly powered off"
Case "R"
strHeaderText = "Scheduled restart"
intShutdownFlag = WMI_Shutdown_Reboot
strRestartText = "restarted"
Case "RF"
strHeaderText = "Scheduled restart"
intShutdownFlag = WMI_Shutdown_RebootForced
strRestartText = "forcibly restarted"
Case "S"
intShutdownFlag = WMI_Shutdown_Shutdown
strHeaderText = "Scheduled shut-down"
strRestartText = "shut down"
Case "SF"
strHeaderText = "Scheduled shut-down"
intShutdownFlag = WMI_Shutdown_ShutdownForced
strRestartText = "forcibly shut down"
End Select
End If
End Sub
Sub CalculateTimeout()
If Len(strHours) > 1 Then
If Left(strHours, 1) = "0" Then
strHours = Right(strHours, 1)
End If
End If
intHours = CInt(strHours)
If Len(strMinutes) > 1 Then
If Left(strMinutes, 1) = "0" Then
strMinutes = Right(strMinutes, 1)
End If
End If
intMinutes = CInt(strMinutes)
If Len(strSeconds) > 1 Then
If Left(strSeconds, 1) = "0" Then
strSeconds = Right(strSeconds, 1)
End If
End If
intSeconds = CInt(strSeconds)
End Sub
Sub CheckCountdown(ByVal blnMinise, ByVal intInHours, ByVal intInMinutes, ByVal intInSeconds)
Dim intHoursToExecutionTime
Dim intMinutesToExecutionTime
Dim intSecondsToExecutionTime
If blnMinise Then
'// Minimise all open windows, to make ours stand out
objWSHShellApp.MinimizeAll
End If
datCountdownStartedTime = Now()
intHoursToExecutionTime = 0
intMinutesToExecutionTime = 0
intSecondsToExecutionTime = 0
If intInHours =0 And intInMinutes = 0 And intInSeconds = 0 Then
intSecondsToExecutionTime = 2
Else
If intInHours > 0 Then
intHoursToExecutionTime = intInHours
End If
If intInMinutes > 0 Then
intMinutesToExecutionTime= (intHoursToExecutionTime * 60) + intInMinutes
End If
intSecondsToExecutionTime = (intMinutesToExecutionTime * 60) + intInSeconds
End If
datExecutionTime = DateAdd("s",intSecondsToExecutionTime, datCountdownStartedTime)
intTimerID = window.setInterval("DoCountdown()", 1000)
End Sub
Sub DoCountdown()
strCountdownStartedTime = DatePart("h", datCountdownStartedTime) & ":"
strCountdownStartedTime = strCountdownStartedTime & Right("00" & DatePart("n", datCountdownStartedTime), 2) & ":"
strCountdownStartedTime = strCountdownStartedTime & Right("00" & DatePart("s", datCountdownStartedTime), 2)
strExecutionTime = DatePart("h", datExecutionTime) & ":"
strExecutionTime = strExecutionTime & Right("00" & DatePart("n", datExecutionTime), 2) & ":"
strExecutionTime = strExecutionTime & Right("00" & DatePart("S", datExecutionTime), 2)
strCurrentTime = DatePart("h", Now()) & ":"
strCurrentTime = strCurrentTime & Right("00" & DatePart("n", Now()), 2) & ":"
strCurrentTime = strCurrentTime & Right("00" & DatePart("s", Now()), 2)
blnResult = CalculateTimeSpan(Now(), datExecutionTime, strRemainingTime)
spanCountdownStarted.InnerText = strCountdownStartedTime
spanExecutionTime.InnerText = strExecutionTime
spanCurrentTime.InnerText = strCurrentTime
spanRemainingTime.InnerText = strRemainingTime
If strRemainingTime = "00:00:00" Then
Call ClearCountdown
Shutdown(intShutdownFlag)
End If
End Sub
Function CalculateTimeSpan(ByVal datFirst, ByVal datSecond, ByRef strTimeSpan)
Dim strSpanHours
Dim strSpanstrSpanMinutes
Dim strSpanSeconds
If (IsDate(datFirst) And IsDate(datSecond)) = False Then
strTimeSpan = "00:00:00"
Exit Function
End If
strSpanSeconds = Abs(DateDiff("S", datFirst, datSecond))
strSpanMinutes = strSpanSeconds \ 60
strSpanHours = strSpanMinutes \ 60
strSpanMinutes = strSpanMinutes mod 60
strSpanSeconds = strSpanSeconds mod 60
If Len(strSpanHours) = 1 Then
strSpanHours = "0" & strSpanHours
End If
strTimeSpan = strSpanHours & ":" & Right("00" & strSpanMinutes, 2) & ":" & Right("00" & strSpanSeconds, 2)
End Function
Sub ClearCountdown
'// Because of most browser's idiotic behaviour with empty table cells,
'// we populate them with spaces
Dim strSpaces
strSpaces = String(4, " ")
spanCountdownStarted.InnerText = strSpaces
spanExecutionTime.InnerText = strSpaces
spanCurrentTime.InnerText = strSpaces
spanRemainingTime.InnerText = strSpaces
window.clearInterval(intTimerID)
End Sub
Sub Shutdown(ByVal intShutdownFlag)
Dim objWMIService
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown )}").InstancesOf("Win32_OperatingSystem")
For Each objSystem In objWMIService
objSystem.Win32Shutdown intShutdownFlag
Next
Set objWMIService = Nothing
End Sub
Sub DoCancel
Window.Close
End Sub
Sub btnQuit_onClick
Call ExitScript
End Sub
Sub ExitScript
'// So that no-one knows we've been, reset the Custom Zone
'objWshShell.RegWrite strIEAccessDataAcrossDomainsLocalRegKey, 1, "REG_DWORD"
'If Err.Number <> 0 Then
' strMsg = "Unable to write IE Security registry value."
' MsgBox strMsg, vbOKonly + vbCritical
'End If
self.Close
End Sub
Sub HandleKeys
Select Case window.event.keycode
Case 13
Call btnExecute_onClick
Case 27
Call btnQuit_onClick
End Select
End Sub
Sub GetScreenSize(ByRef intHorizontal, ByRef intVertical)
Dim strComputer
Dim objWMIService_GSS
Dim colItems
Dim objItem
strComputer = "."
Set objWMIService_GSS = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService_GSS.ExecQuery("Select * From Win32_DesktopMonitor")
For Each objItem In colItems
intHorizontal = objItem.ScreenWidth
intVertical = objItem.ScreenHeight
Exit For
Next
Set colItems = Nothing
Set objWMIService_GSS = Nothing
End Sub
Sub ResizeWindow(ByVal intWidth, ByVal intHeight, ByVal blnShowMsg)
Dim intH
Dim intV
Dim objMessageAreaResize
With Window
If blnShowMsg Then
Set objMessageAreaResize = .document.getElementById("HeaderArea")
objMessageAreaResize.InnerHTML = "Resizing window"
Set objMessageAreaResize = Nothing
End If
.resizeTo intWidth,intHeight
End With
End Sub
Sub CentreWindow(ByVal intWidth, ByVal intHeight, ByVal blnShowMsg)
Dim intH
Dim intV
Dim intLeft
Dim intTop
Dim objMessageAreaCentre
Call GetScreenSize(intH, intV)
intLeft = (intH - intWidth) / 2
intTop = (intV - intHeight) / 2
With Window
If blnShowMsg Then
Set objMessageAreaCentre = .document.getElementById("HeaderArea")
objMessageAreaCentre.InnerHTML = "Centering window"
Set objMessageAreaCentre = Nothing
End If
.moveTo intLeft, intTop
End With
End Sub
'// =========================================================================================================
'// Name: GetSubstringCount
'// Purpose: Determines how many times one string occurs in another string
'// Input: strToLookFor - the string to look for
'// strSearch - the string to look in
'// blnIgnoreCase - If True, ignore case of both strings
'// Output: intStringCount - a 'ByRef' variable which will contain the number of occurrences
'// Returns: True/False
'// =========================================================================================================
Function GetSubstringCount(ByVal strToLookFor, ByVal strSearch, ByVal blnIgnoreCase, ByRef intStringCount)
'// Since VBS doesn't provide a string counter (i.e. how many times a string occurs in another string)
'// we hack it using Split: the UBound of the array will tell us how many occurrences there are, if any
'// Assume the worst
intStringCount = 0
GetSubstringCount = False
If Len(strToLookFor) = 0 Then
strMsg = "A parameter, 'strToLookFor', passed to " & strScriptName & ".GetSubstringCount is empty."
'errStatus = MsgUsr(strMsg, intButtonType, strScriptName & ".GetSubstringCount", intButtonPressed)
Exit Function
End If
If Len(strSearch) = 0 Then
strMsg = "A parameter, 'strSearch', passed to " & strScriptName & ".GetSubstringCount is empty."
'errStatus = MsgUsr(strMsg, intButtonType, strScriptName & ".GetSubstringCount", intButtonPressed)
Exit Function
End If
If blnIgnoreCase Then
intStringCount = UBound(Split(strSearch, strToLookFor))
Else
intStringCount = UBound(Split(UCase(strSearch), UCase(strToLookFor)))
End If
GetSubstringCount = True
End Function
'//=========================================================================================================
'// Name: StringMatch
'// Purpose: Checks if two strings match
'// Why not use 'If strFirst = strSecond', you're asking?
'// Well, the 'Equals' operator :
'// - is not very fast (at string comparison)!
'// - compares strings left to right and is smart enough to stop comparing when it spots the first difference, but
'// - is too dumb to first do the most obvious test: comparing the lengths of the strings!
'// Input: strFirst - the first string
'// strSecond - the second string
'// blnMatch - a Boolean indicating whether or not the strings matched
'// Output: None
'// Returns: True/False
'//
'//=========================================================================================================
Function StringMatch(ByVal strFirst, ByVal strSecond, ByRef blnMatch)
StringMatch = True
blnMatch = False
If LenB(strFirst) = LenB(strSecond) Then
blnMatch = (InStrB(1, strFirst, strSecond, vbBinaryCompare) <> 0)
End If
End Function
</SCRIPT>
</HEAD>
<BODY onKeyPress='HandleKeys()'>
<DIV ID="pagewidth1">
<DIV ID="top_body">
<P><IMG SRC="lvlogo.gif" /></p>
<P> </P>
<H1><SPAN ID=spanHeader></SPAN></H1>
<P> </P>
</DIV>
</DIV>
<P ALIGN="center">
This computer is scheduled to be <SPAN ID='spanRestartText'></SPAN>.<BR>Please click the 'Cancel' button if you wish to continue using it.
</P>
<TABLE WIDTH='98%' BORDER=0>
<TR>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanCountdownStartedPrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanCountdownStarted'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='5%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanExecutionTimePrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanExecutionTime'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
</TR>
<TR>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanCurrentTimePrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanCurrentTime'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='5%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanRemainingTimePrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanRemainingTime'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
</TR>
</TABLE>
<TABLE WIDTH='98%' BORDER=0>
<TR>
<TD>
<FONT SIZE="2">
</FONT>
</TD>
</TR>
<TR>
<TD ALIGN='CENTER'>
<FONT SIZE="2">
<INPUT ACCESSKEY='Q' CLASS="button" TYPE="button" VALUE="Cancel" ID='btnQuit' NAME='btnQuit'>
</FONT>
</TD>
</TR>
</TABLE>
</BODY>
</HTML>
Posted by:
captain_planet
14 years ago
I guess the only way to do via Marimba is to use a Customization. And i also guess that you dont want this message appearing after every single install (ie, those which dont require a reboot). So from that, you'd need to capture the return code and handle it from there. Here's a rough script which you can hack around with. You might even want to merge parts of it into VBScabs HTA above, especially if you wanted to use dropdowns to specify hours of delay etc.
Dim installerReturnCode, rebootPCReturn
Dim rebootMsg : rebootMsg = "Would you like to reboot now? (Selecting 'No' will remind you in 1 hour)"
Set WshShell = WScript.CreateObject("WScript.Shell")
installerReturnCode = WshShell.Run("msiexec.exe /i whatever.msi /qb!", 0, True)
'3010 = reboot requested
If installerReturnCode = "3010" Then
rebootPCReturn = MsgBox(rebootMsg, 4 + 32)
Do While rebootPCReturn <> 6
'sleep for an Hour
WScript.Sleep(3600000)
rebootPCReturn = MsgBox(rebootMsg, 4 + 32)
Loop
'finally, user has decided to reboot
If rebootPCReturn = 6 Then
WshShell.Run "shutdown.exe /r /t 10 /c "" This system will automatically restart in a moment..."" /f /d p:4:1", 0, False
End If
End If
Set WshShell = Nothing
Posted by:
captain_planet
14 years ago
Oh, and make sure you check the box in the customization which says 'Run script as detached process' otherwise the install will never end....unless you reboot!
In my opinion, it's all just overkill. Give me a simple yes/no box any day. No extra processes running in the background, and no pop-up reminders that do my head in. I hate things reminding me to reboot. But then again that's just my opinion. If i click 'no' and i try running my app 4 hours later and it doesn't work because i haven't rebooted - tough. I'd been told. Mind you, i guess that wont stop *some* drongo's raising support calls.....
In my opinion, it's all just overkill. Give me a simple yes/no box any day. No extra processes running in the background, and no pop-up reminders that do my head in. I hate things reminding me to reboot. But then again that's just my opinion. If i click 'no' and i try running my app 4 hours later and it doesn't work because i haven't rebooted - tough. I'd been told. Mind you, i guess that wont stop *some* drongo's raising support calls.....
Posted by:
guru533
14 years ago
Thank you very much to both of you. I will look through these scripts and try to get it to work with Marimba.
The thing that is strange with Marimba and which I do not like, is they have this message box for their Patch system, but only gives a simple Yes/No box for the application side. I have not been able to get a straight answer as to why this is the case.
The problem with the Yes/No box they have is it is not customizable. There is no timeout function, so the box can just sit there forever and hangs other updates from coming down. The problem, which is useless in any case with the first issue being present, is you cannot customize the message.
The thing that is strange with Marimba and which I do not like, is they have this message box for their Patch system, but only gives a simple Yes/No box for the application side. I have not been able to get a straight answer as to why this is the case.
The problem with the Yes/No box they have is it is not customizable. There is no timeout function, so the box can just sit there forever and hangs other updates from coming down. The problem, which is useless in any case with the first issue being present, is you cannot customize the message.
Posted by:
anonymous_9363
14 years ago
Here's a revised version which handles the command line a little more elegantly. The earlier one would have problems with folder names which have a space. There's also now a '/help' argument and I've separated the options from the 'force' parameter into a separate argument.
<!DOCTYPE HTML PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd>
<HTML xmlns:yCode>
<TITLE>Scheduled shutdown</TITLE>
<HTA:APPLICATION
ID = "DoShutdown"
APPLICATIONNAME = "DoShutdown"
BORDER = "None"
BORDERSTYLE = "Normal"
CAPTION = "Yes"
CONTEXTMENU = "No"
INNERBORDER = "Yes"
MAXIMIZEBUTTON = "No"
MINIMIZEBUTTON = "No"
NAVIGABLE = "No"
SCROLL = "No"
SCROLLFLAT = "Yes"
SELECTION = "No"
SHOWINTASKBAR = "No"
SINGLEINSTANCE = "Yes"
SYSMENU = "No"
>
<HEAD>
<STYLE>
HTML, BODY
{
margin: 0;
padding: 0;
line-height: 1.5em;
font-size: 87%;
font-family: Verdana, Arial, Helvetica, sans-serif;
}
#top_body
{
clear: both;
margin: 20px 0 0 0;
text-align: center;
}
#top_body p
{
margin: 20px 0 0 0;
font-style: italic;
}
H1
{
color:#FF0000;
font-weight: bold;
text-transform: uppercase;
font-family: "Arial Narrow", Arial, Helvetica, sans-serif;
font-size: 3em; margin: 0 15px 0 0;
letter-spacing: -.05em;
}
H2
{
color: #4e4a4e;
font-weight: bold;
font-size: 1.4em;
margin: 15px 0 0 0;
}
INPUT
{
font-family: tahoma;
font-size: 18pt;
}
</STYLE>
<SCRIPT LANGUAGE="VBScript">
Public intReturn
Public objFSO
Public objWSHShell
Public objWSHShellApp
Public strDummy
Public strArgument
Public blnArgumentsAreValid
Public strHTA
Public strHTAPath
Public strAppRootFolder
Public strCommandLine
Public dicArguments
Public intSlashPos
Public intHTANamePos
Public intSpacePos
Public strHours
Public strMinutes
Public strSeconds
Public datCountdownStartedTime
Public datExecutionTime
Public datCurrentTime
Public datRemainingTime
Public strCountdownStartedTime
Public strExecutionTime
Public strCurrentTime
Public strRemainingTime
Public intHours
Public intMinutes
Public intSeconds
Public intTimerID
Public strRestartType
Public strHeaderText
Public strRestartText
Const intWindowWidth = 550
Const intWindowHeight = 410
Const WMI_Shutdown_LogOff = 0
Const WMI_Shutdown_Forced = 4
Const WMI_Shutdown_PowerOff = 8
Const WMI_Shutdown_Reboot = 2
Const WMI_Shutdown_Shutdown = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objWSHShell = CreateObject("WScript.Shell")
Set objWSHShellApp = CreateObject("Shell.Application")
Set dicArguments = CreateObject("Scripting.Dictionary")
dicArguments.CompareMode = vbTextcompare '// Set case insensitivity for arguments
'// Set default timeout for 5 minutes
intHours = 0
intMinutes = 5
intSeconds = 0
'// Set default shutdown type
strRestartType = "RF"
intShutdownFlag = WMI_Shutdown_RebootForced
strRestartText = "restarted"
strHeaderText = "Scheduled restart"
Sub Window_Onload
Dim blnShow
Dim blnMiniseAllOpenWindows
Dim objFileHTA
Dim blnResult_Window
Dim intCountColon
Dim intCountSpace
strCommandLine = Trim(DoShutdown.CommandLine)
blnMiniseAllOpenWindows = True
'// Ditch the stupid quotes which MS has decreed will surround the name
'// even when there are no spaces in ANY folder name!
strCommandLine = Replace(strCommandLine, Chr(34), "")
'// Bizarrely, if an argument is passed to an HTA and we remove the quote marks,
'// we get an extra space character!
If InStr(strCommandLine, " ") > 0 Then
strCommandLine = Replace(strCommandLine, " ", " ")
End If
Call ParseArguments
Call AssignAndValidateArguments
If Not blnArgumentsAreValid Then
ExitScript
End If
Call ResizeWindow(intWindowWidth, intWindowHeight, blnShow)
Call CentreWindow(intWindowWidth, intWindowHeight, blnShow)
spanHeader.InnerText = strHeaderText
spanRestartText.InnerText = strRestartText
spanCountdownStartedPrompt.InnerText = "Countdown Started:"
spanExecutionTimePrompt.InnerText = "Execution Time:"
spanCurrentTimePrompt.InnerText = "Current Time:"
spanRemainingTimePrompt.InnerText = "Remaining Time:"
Call CalculateTimeout
Call CheckCountdown(blnMiniseAllOpenWindows, intHours,intMinutes,intSeconds)
End Sub
Sub ParseArguments
Dim blnResult_Parse
Dim arrAllArguments
Dim strAllArguments
Dim arrArgument
Dim strArgument
Dim intArgumentPos
On Error Resume Next
With document
strDummy = .url
strHTA = Mid(strDummy, Len("file://" ) + 1 )
strHTAPath = objFSO.GetParentFolderName(strDummy)
End With
intArgumentPos = InStr(strCommandLine, "/")
If intArgumentPos = 0 Then
Exit Sub
End If
strAllArguments = Trim(Split(strCommandLine, strHTA)(1))
arrAllArguments = Split(strAllArguments, " ")
For Each strArgument In arrAllArguments
arrArgument = Split(strArgument, "=", 2)
'/ If value is specified multiple times, last one wins
If dicArguments.Exists(Trim(arrArgument(0))) Then
dicArguments.Remove(Trim(arrArgument(0)))
End If
If UBound(arrArgument) >= 1 Then
dicArguments.Add Trim(arrArgument(0)), Trim(arrArgument(1))
Else
dicArguments.Add Trim(arrArgument(0)),""
End If
Next
On Error Goto 0
End Sub
Sub AssignAndValidateArguments
Dim intCountColon
Dim intCountSpace
Dim strAction
Dim strCountdownTime
Dim blnForce
blnArgumentsAreValid = False
'// Check for -help, -? etc help request on command line
If (dicArguments.Count < 1) Or (dicArguments.Exists("help")) or (dicArguments.Exists("/help")) or (dicArguments.Exists("?")) or (dicArguments.Exists("/?")) Then
strDummy = "Command line switches for this application are:"
strDummy = strDummy & vbCRLF & vbCRLF
strDummy = strDummy & vbTAB & "/T=hh:mm:ss" & vbTAB & "Sets the number of hours, minutes and seconds to countdown before shutdown/restart occurs."
strDummy = strDummy & vbCRLF
strDummy = strDummy & vbTAB & vbTAB & vbTAB & "Use hh:mm:ss format."
strDummy = strDummy & vbCRLF & vbCRLF
strDummy = strDummy & vbTAB & "/A=x" & vbTAB & vbTAB & "Sets the action to take."
strDummy = strDummy & " Valid options for 'x' are:"
strDummy = strDummy & vbCRLF
strDummy = strDummy & vbTAB & vbTAB & vbTAB & vbTAB & "L" & vbTAB & "- log the user off"
strDummy = strDummy & vbCRLF
strDummy = strDummy & vbTAB & vbTAB & vbTAB & vbTAB & "P" & vbTAB & "- power-off the machine"
strDummy = strDummy & vbCRLF
strDummy = strDummy & vbTAB & vbTAB & vbTAB & vbTAB & "R" & vbTAB & "- restart the machine"
strDummy = strDummy & vbCRLF
strDummy = strDummy & vbTAB & vbTAB & vbTAB & vbTAB & "S" & vbTAB & "- shutdown the machine"
strDummy = strDummy & vbCRLF
strDummy = strDummy & vbTAB & "/F" & vbTAB & vbTAB & "Forces the action."
strDummy = strDummy & vbCRLF
MsgBox strDummy,vbOKOnly
Exit Sub
End If
strAction = dicArguments("/A")
strCountdownTime = dicArguments("/T")
If dicArguments.Exists("/F") Then
blnForce = True
End If
'// Validate dependencies
If strAction = "" Then
strDummy = "You must specify the '/A' argument."
' MsgBox strDummy,vbOKOnly
' Exit Sub
'// As a default, let's set a restart
strHeaderText = "Scheduled restart"
intShutdownFlag = WMI_Shutdown_Reboot
strRestartText = "restarted"
Else
Select Case strAction
Case "L"
strHeaderText = "Scheduled log-off"
intShutdownFlag = WMI_Shutdown_LogOff
strRestartText = "logged off"
Case "P"
strHeaderText = "Scheduled power-off"
intShutdownFlag = WMI_Shutdown_PowerOff
strRestartText = "powered off"
Case "R"
strHeaderText = "Scheduled restart"
intShutdownFlag = WMI_Shutdown_Reboot
strRestartText = "restarted"
Case "S"
strHeaderText = "Scheduled shut-down"
intShutdownFlag = WMI_Shutdown_Shutdown
strRestartText = "shut down"
End Select
If blnForce Then
intShutdownFlag = intShutdownFlag & WMI_Shutdown_Forced
strRestartText = "forcibly " & strRestartText
End If
End If
If Len(strCountdownTime) > 0 Then
If InStr(strCountdownTime, ":") > 0 Then
blnResult_Parse = GetSubstringCount(":", strCountdownTime, True, intCountColon)
If (intCountColon > 2) Or (intCountColon < 1) Then
'// Twat...
Else
strHours = Split(strCountdownTime, ":")(0)
strMinutes = Split(strCountdownTime, ":")(1)
strSeconds = Split(strCountdownTime, ":")(2)
End If
End If
End If
blnArgumentsAreValid = True
End Sub
Sub CalculateTimeout()
If Len(strHours) > 1 Then
If Left(strHours, 1) = "0" Then
strHours = Right(strHours, 1)
End If
End If
intHours = CInt(strHours)
If Len(strMinutes) > 1 Then
If Left(strMinutes, 1) = "0" Then
strMinutes = Right(strMinutes, 1)
End If
End If
intMinutes = CInt(strMinutes)
If Len(strSeconds) > 1 Then
If Left(strSeconds, 1) = "0" Then
strSeconds = Right(strSeconds, 1)
End If
End If
intSeconds = CInt(strSeconds)
End Sub
Sub CheckCountdown(ByVal blnMinise, ByVal intInHours, ByVal intInMinutes, ByVal intInSeconds)
Dim intHoursToExecutionTime
Dim intMinutesToExecutionTime
Dim intSecondsToExecutionTime
If blnMinise Then
'// Minimise all open windows, to make ours stand out
objWSHShellApp.MinimizeAll
End If
datCountdownStartedTime = Now()
intHoursToExecutionTime = 0
intMinutesToExecutionTime = 0
intSecondsToExecutionTime = 0
If intInHours =0 And intInMinutes = 0 And intInSeconds = 0 Then
intSecondsToExecutionTime = 2
Else
If intInHours > 0 Then
intHoursToExecutionTime = intInHours
End If
If intInMinutes > 0 Then
intMinutesToExecutionTime= (intHoursToExecutionTime * 60) + intInMinutes
Else
intMinutesToExecutionTime= (intHoursToExecutionTime * 60)
End If
intSecondsToExecutionTime = (intMinutesToExecutionTime * 60) + intInSeconds
End If
datExecutionTime = DateAdd("s",intSecondsToExecutionTime, datCountdownStartedTime)
intTimerID = window.setInterval("DoCountdown()", 1000)
End Sub
Sub DoCountdown()
strCountdownStartedTime = DatePart("h", datCountdownStartedTime) & ":"
strCountdownStartedTime = strCountdownStartedTime & Right("00" & DatePart("n", datCountdownStartedTime), 2) & ":"
strCountdownStartedTime = strCountdownStartedTime & Right("00" & DatePart("s", datCountdownStartedTime), 2)
strExecutionTime = DatePart("h", datExecutionTime) & ":"
strExecutionTime = strExecutionTime & Right("00" & DatePart("n", datExecutionTime), 2) & ":"
strExecutionTime = strExecutionTime & Right("00" & DatePart("S", datExecutionTime), 2)
strCurrentTime = DatePart("h", Now()) & ":"
strCurrentTime = strCurrentTime & Right("00" & DatePart("n", Now()), 2) & ":"
strCurrentTime = strCurrentTime & Right("00" & DatePart("s", Now()), 2)
blnResult = CalculateTimeSpan(Now(), datExecutionTime, strRemainingTime)
spanCountdownStarted.InnerText = strCountdownStartedTime
spanExecutionTime.InnerText = strExecutionTime
spanCurrentTime.InnerText = strCurrentTime
spanRemainingTime.InnerText = strRemainingTime
If strRemainingTime = "00:00:00" Then
Call ClearCountdown
Shutdown(intShutdownFlag)
End If
End Sub
Function CalculateTimeSpan(ByVal datFirst, ByVal datSecond, ByRef strTimeSpan)
Dim strSpanHours
Dim strSpanstrSpanMinutes
Dim strSpanSeconds
If (IsDate(datFirst) And IsDate(datSecond)) = False Then
strTimeSpan = "00:00:00"
Exit Function
End If
strSpanSeconds = Abs(DateDiff("S", datFirst, datSecond))
strSpanMinutes = strSpanSeconds \ 60
strSpanHours = strSpanMinutes \ 60
strSpanMinutes = strSpanMinutes mod 60
strSpanSeconds = strSpanSeconds mod 60
If Len(strSpanHours) = 1 Then
strSpanHours = "0" & strSpanHours
End If
strTimeSpan = strSpanHours & ":" & Right("00" & strSpanMinutes, 2) & ":" & Right("00" & strSpanSeconds, 2)
End Function
Sub ClearCountdown
'// Because of most browser's idiotic behaviour with empty table cells,
'// we populate them with spaces
Dim strSpaces
strSpaces = String(4, " ")
spanCountdownStarted.InnerText = strSpaces
spanExecutionTime.InnerText = strSpaces
spanCurrentTime.InnerText = strSpaces
spanRemainingTime.InnerText = strSpaces
window.clearInterval(intTimerID)
End Sub
Sub Shutdown(ByVal intShutdownFlag)
Dim objWMIService
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown )}").InstancesOf("Win32_OperatingSystem")
For Each objSystem In objWMIService
objSystem.Win32Shutdown intShutdownFlag
Next
Set objWMIService = Nothing
End Sub
Sub DoCancel
Window.Close
End Sub
Sub btnQuit_onClick
Call ExitScript
End Sub
Sub ExitScript
'// So that no-one knows we've been, reset the Custom Zone
'objWshShell.RegWrite strIEAccessDataAcrossDomainsLocalRegKey, 1, "REG_DWORD"
'If Err.Number <> 0 Then
' strMsg = "Unable to write IE Security registry value."
' MsgBox strMsg, vbOKonly + vbCritical
'End If
Set dicArguments = Nothing
Set objWSHShellApp = Nothing
Set objWSHShell = Nothing
Set objFSO = Nothing
self.Close
End Sub
Sub HandleKeys
Select Case window.event.keycode
Case 13
Call btnExecute_onClick
Case 27
Call btnQuit_onClick
End Select
End Sub
Sub GetScreenSize(ByRef intHorizontal, ByRef intVertical)
Dim strComputer
Dim objWMIService_GSS
Dim colItems
Dim objItem
strComputer = "."
Set objWMIService_GSS = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService_GSS.ExecQuery("Select * From Win32_DesktopMonitor")
For Each objItem In colItems
intHorizontal = objItem.ScreenWidth
intVertical = objItem.ScreenHeight
Exit For
Next
Set colItems = Nothing
Set objWMIService_GSS = Nothing
End Sub
Sub ResizeWindow(ByVal intWidth, ByVal intHeight, ByVal blnShowMsg)
Dim intH
Dim intV
Dim objMessageAreaResize
With Window
If blnShowMsg Then
Set objMessageAreaResize = .document.getElementById("HeaderArea")
objMessageAreaResize.InnerHTML = "Resizing window"
Set objMessageAreaResize = Nothing
End If
.resizeTo intWidth,intHeight
End With
End Sub
Sub CentreWindow(ByVal intWidth, ByVal intHeight, ByVal blnShowMsg)
Dim intH
Dim intV
Dim intLeft
Dim intTop
Dim objMessageAreaCentre
Call GetScreenSize(intH, intV)
intLeft = (intH - intWidth) / 2
intTop = (intV - intHeight) / 2
With Window
If blnShowMsg Then
Set objMessageAreaCentre = .document.getElementById("HeaderArea")
objMessageAreaCentre.InnerHTML = "Centering window"
Set objMessageAreaCentre = Nothing
End If
.moveTo intLeft, intTop
End With
End Sub
'// =========================================================================================================
'// Name: GetSubstringCount
'// Purpose: Determines how many times one string occurs in another string
'// Input: strToLookFor - the string to look for
'// strSearch - the string to look in
'// blnIgnoreCase - If True, ignore case of both strings
'// Output: intStringCount - a 'ByRef' variable which will contain the number of occurrences
'// Returns: True/False
'// =========================================================================================================
Function GetSubstringCount(ByVal strToLookFor, ByVal strSearch, ByVal blnIgnoreCase, ByRef intStringCount)
'// Since VBS doesn't provide a string counter (i.e. how many times a string occurs in another string)
'// we hack it using Split: the UBound of the array will tell us how many occurrences there are, if any
'// Assume the worst
intStringCount = 0
GetSubstringCount = False
If Len(strToLookFor) = 0 Then
strMsg = "A parameter, 'strToLookFor', passed to " & strScriptName & ".GetSubstringCount is empty."
'errStatus = MsgUsr(strMsg, intButtonType, strScriptName & ".GetSubstringCount", intButtonPressed)
Exit Function
End If
If Len(strSearch) = 0 Then
strMsg = "A parameter, 'strSearch', passed to " & strScriptName & ".GetSubstringCount is empty."
'errStatus = MsgUsr(strMsg, intButtonType, strScriptName & ".GetSubstringCount", intButtonPressed)
Exit Function
End If
If blnIgnoreCase Then
intStringCount = UBound(Split(strSearch, strToLookFor))
Else
intStringCount = UBound(Split(UCase(strSearch), UCase(strToLookFor)))
End If
GetSubstringCount = True
End Function
'//=========================================================================================================
'// Name: StringMatch
'// Purpose: Checks if two strings match
'// Why not use 'If strFirst = strSecond', you're asking?
'// Well, the 'Equals' operator :
'// - is not very fast (at string comparison)!
'// - compares strings left to right and is smart enough to stop comparing when it spots the first difference, but
'// - is too dumb to first do the most obvious test: comparing the lengths of the strings!
'// Input: strFirst - the first string
'// strSecond - the second string
'// blnMatch - a Boolean indicating whether or not the strings matched
'// Output: None
'// Returns: True/False
'//
'//=========================================================================================================
Function StringMatch(ByVal strFirst, ByVal strSecond, ByRef blnMatch)
StringMatch = True
blnMatch = False
If LenB(strFirst) = LenB(strSecond) Then
blnMatch = (InStrB(1, strFirst, strSecond, vbBinaryCompare) <> 0)
End If
End Function
</SCRIPT>
</HEAD>
<BODY onKeyPress='HandleKeys()'>
<DIV ID="pagewidth1">
<DIV ID="top_body">
<P><IMG SRC="DoShutdownClientLogo.gif" /></p>
<P> </P>
<H1><SPAN ID=spanHeader></SPAN></H1>
<P> </P>
</DIV>
</DIV>
<P ALIGN="center">
This computer is scheduled to be <SPAN ID='spanRestartText'></SPAN>.<BR>Please click the 'Cancel' button if you wish to continue using it.
</P>
<TABLE WIDTH='98%' BORDER=0>
<TR>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanCountdownStartedPrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanCountdownStarted'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='5%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanExecutionTimePrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanExecutionTime'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
</TR>
<TR>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanCurrentTimePrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanCurrentTime'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='5%'>
<FONT SIZE="2">
</FONT>
</TD>
<TD WIDTH='30%' ALIGN='RIGHT'>
<FONT SIZE="2">
<SPAN ID='spanRemainingTimePrompt'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='17%' ALIGN='LEFT'>
<FONT SIZE="2">
<SPAN ID='spanRemainingTime'>
</SPAN>
</FONT>
</TD>
<TD WIDTH='1%'>
<FONT SIZE="2">
</FONT>
</TD>
</TR>
</TABLE>
<TABLE WIDTH='98%' BORDER=0>
<TR>
<TD>
<FONT SIZE="2">
</FONT>
</TD>
</TR>
<TR>
<TD ALIGN='CENTER'>
<FONT SIZE="2">
<INPUT ACCESSKEY='Q' CLASS="button" TYPE="button" VALUE="Cancel" ID='btnQuit' NAME='btnQuit'>
</FONT>
</TD>
</TR>
</TABLE>
</BODY>
</HTML>
Rating comments in this legacy AppDeploy message board thread won't reorder them,so that the conversation will remain readable.