保持一个VBScript窗口顶部，以及添加一个注销按钮

我有一段脚本，用户Hackoo的courtosey，但有两件事是错误的。首先，窗口需要保持在最前面，它不应该能够从任务栏退出，它需要位于屏幕的右下角（位于任务栏上方），并且它需要在其下面有一个按钮说“注销”的文字。当然，注销按钮需要注销计算机。下面的代码：保持一个VBScript窗口顶部，以及添加一个注销按钮

Option Explicit 
Dim Title,ws,nMinutes,nSeconds,sMessage 
Title = "Session Timer" 
Set ws = CreateObject("wscript.Shell") 
nMinutes = 20 
nSeconds = 0 
sMessage = "<font color=Red size=2><b>You have" 
'Open a chromeless window with message 
with HTABox("lightBlue",100,250,0,630) 
.document.title = "Session Timer" 
.msg.innerHTML = sMessage 
do until .done.value or (nMinutes + nSeconds < 1) 
    .msg.innerHTML = sMessage & "<br>" & nMinutes & ":" & Right("0"&nSeconds, 2) _ 
    & " minutes of session time remaining</b></font><br>" 
    wsh.sleep 1000 ' milliseconds 
    nSeconds = nSeconds - 1 
    if nSeconds < 0 then 
     if nMinutes > 0 then 
      nMinutes = nMinutes - 1 
      nSeconds = 59 
     end if 
    end if 
loop 
.done.value = true 
.close 
end with 
ws.Popup "Your session time has finished. You will now be logged   off.","5",Title,0+48 
'***************************************************************** 
Function HTABox(sBgColor, h, w, l, t) 
Dim IE, HTA, sCmd, nRnd 
randomize : nRnd = Int(1000000 * rnd) 
sCmd = "mshta.exe ""javascript:{new " _ 
& "ActiveXObject(""InternetExplorer.Application"")" _ 
& ".PutProperty('" & nRnd & "',window);" _ 
& "window.resizeTo(" & w & "," & h & ");" _ 
& "window.moveTo(" & l & "," & t & ")}""" 
with CreateObject("WScript.Shell") 
    .Run sCmd, 1, False 
    do until .AppActivate("javascript:{new ") : WSH.sleep 10 : loop 
    end with 'WSHShell 
    For Each IE In CreateObject("Shell.Application").windows 
     If IsObject(IE.GetProperty(nRnd)) Then 
      set HTABox = IE.GetProperty(nRnd) 
      IE.Quit 
      HTABox.document.title = "HTABox" 
      HTABox.document.write _ 
      "<HTA:Application contextMenu=no border=thin " _ 
      & "minimizebutton=no maximizebutton=no sysmenu=no    SHOWINTASKBAR=no >" _ 
      & "<body scroll=no style='background-color:" _ 
      & sBgColor & ";font:normal 10pt Arial;" _ 
      & "border-Style:inset;border-Width:3px'" _ 
      & "onbeforeunload='vbscript:if not done.value then " _ 
      & "window.event.cancelBubble=true:" _ 
      & "window.event.returnValue=false:" _ 
      & "done.value=true:end if'>" _ 
      & "<input type=hidden id=done value=false>" _ 
      & "<center><span id=msg>&nbsp;</span><br>" _ 
      & "<input type=button id=btn1 value=' OK ' "_ 
      & "onclick=done.value=true><center></body>" 
      HTABox.btn1.focus 
      Exit Function 
     End If 
    Next 
    MsgBox "HTA window not found." 
    wsh.quit 
End Function

感谢，马修

来源

2015-04-13 Matthew Taylor

请注意，我不认为我们可以呆在总是在顶部，但无论如何，只要给这一修改的一个尝试，现在你希望它在右侧不在左边，我添加了按钮以退出会话：

Option Explicit 
Dim Title,ws,nMinutes,nSeconds,sMessage,Command,Executer 
Title = "Session Timer" 
Set ws = CreateObject("wscript.Shell") 
nMinutes = 20 
nSeconds = 0 
sMessage = "<font color=Red size=2><b>You have" 
'Open a chromeless window with message 
with HTABox("lightBlue",130,300,1070,600) 
.document.title = "Session Timer" 
.msg.innerHTML = sMessage 
do until .done.value or (nMinutes + nSeconds < 1) 
    .msg.innerHTML = sMessage & "<br>" & nMinutes & ":" & Right("0"&nSeconds, 2) _ 
    & " minutes of session time remaining</b></font><br>" 
    wsh.sleep 1000 ' milliseconds 
    nSeconds = nSeconds - 1 
    if nSeconds < 0 then 
     if nMinutes > 0 then 
      nMinutes = nMinutes - 1 
      nSeconds = 59 
     end if 
    end if 
loop 
.done.value = true 
.close 
end with 
ws.Popup "Your session time has finished. You will now be logged off.","5",Title,0+48 
Command ="cmd /c Shutdown.exe -l -f" 
Executer = WS.Run(Command,0,False) 
'***************************************************************** 
Function HTABox(sBgColor,h, w, l, t) 
Dim IE, HTA, sCmd, nRnd 
randomize : nRnd = Int(1000000 * rnd) 
sCmd = "mshta.exe ""javascript:{new " _ 
& "ActiveXObject(""InternetExplorer.Application"")" _ 
& ".PutProperty('" & nRnd & "',window);" _ 
& "window.resizeTo(" & w & "," & h & ");" _ 
& "window.moveTo(" & l & "," & t & ")}""" 
with CreateObject("WScript.Shell") 
    .Run sCmd, 1, False 
    do until .AppActivate("javascript:{new ") : WSH.sleep 10 : loop 
    end with 'WSHShell 
    For Each IE In CreateObject("Shell.Application").windows 
     If IsObject(IE.GetProperty(nRnd)) Then 
      set HTABox = IE.GetProperty(nRnd) 
      IE.Quit 
      HTABox.document.title = "HTABox" 
      HTABox.document.write _ 
      "<HTA:Application contextMenu=no border=thin " _ 
      & "minimizebutton=no maximizebutton=no sysmenu=no SHOWINTASKBAR=no >" _ 
      & "<body scroll=no style='background-color:" _ 
      & sBgColor & ";font:normal 10pt Arial;" _ 
      & "border-Style:inset;border-Width:3px'" _ 
      & "onbeforeunload='vbscript:if not done.value then " _ 
      & "window.event.cancelBubble=true:" _ 
      & "window.event.returnValue=false:" _ 
      & "done.value=true:end if'>" _ 
      & "<input type=hidden id=done value=false>" _ 
      & "<center><span id=msg>&nbsp;</span><br>" _ 
      & "<input type=button id=btn1 value=' Log Off ' "_ 
      & "onclick=done.value=true><center></body>" 
      HTABox.btn1.focus 
      Exit Function 
     End If 
    Next 
    MsgBox "HTA window not found." 
    wsh.quit 
End Function

来源

2015-04-13 00:51:28 Hackoo

谢谢！这很棒。我希望其他人会觉得这很有用。 –

保持一个VBScript窗口顶部，以及添加一个注销按钮

回答

相关问题