Just wondering how i could have a MSgbox that displays the value of a variable as it constantly changes. Basically a number has one added to it everytime it loops. I want to display that in a MSGbox that doesnt have to open a million windows
A workaround would be to use PopUp
Set objShell = WScript.CreateObject("WScript.Shell")
For i = 1 To 3
objShell.Popup i, 1, "AutoClose MsgBox Simulation", vbInformation+vbOKOnly
Next
This will "autoclose" the MsgBox lookalike after 1 second
You can't do this with the default VBScript dialog elements, like MsgBox, WScript.Echo or Popup. You need to build a custom dialog using the Internet Explorer COM object:
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
While ie.ReadyState <> 4 : WScript.Sleep 100 : Wend
ie.ToolBar = False
ie.StatusBar = False
ie.Width = 300
ie.Height = 200
ie.document.body.innerHTML = "<p id='msg'>0</p>"
Set style = ie.document.CreateStyleSheet
style.AddRule "p", "text-align: center;"
ie.Visible = True
i = 1
Do
ie.document.getElementById("msg").innerText = i
i = i + 1
WScript.Sleep 2000
Loop Until i > 10
or use an HTA instead of plain VBScript:
<head>
<title>Test</title>
<HTA:APPLICATION ID="oHTA"
APPLICATIONNAME="Test"
SCROLL="no"
>
</head>
<style type="text/css">
p {text-align: center;}
</style>
<script language="VBScript">
window.resizeTo 300, 200
Set sh = CreateObject("WScript.Shell")
Sub Window_onLoad
For i = 1 To 10
msg.innerText = i
Sleep 2
Next
End Sub
Sub Sleep(t)
sh.Run "ping -n " & (t+1) & " 127.0.0.1", 0, True
End Sub
</script>
<body>
<p id="msg">0</p>
</body>
One more solution, uses HTA window, without temp files:
dim window, i
set window = createwindow()
window.document.write "<html><body bgcolor=buttonface>Current loop is: <span id='output'></span></body></html>"
window.document.title = "Processing..."
window.resizeto 300, 150
window.moveto 200, 200
for i = 0 to 32767
show i
' your code here
next
window.close
function show(value)
on error resume next
window.output.innerhtml = value
if err then wscript.quit
end function
function createwindow()
' source http://forum.script-coding.com/viewtopic.php?pid=75356#p75356
dim signature, shellwnd, proc
on error resume next
set createwindow = nothing
signature = left(createobject("Scriptlet.TypeLib").guid, 38)
set proc = createobject("WScript.Shell").exec("mshta about:""<script>moveTo(-32000,-32000);</script><hta:application id=app border=dialog minimizebutton=no maximizebutton=no scroll=no showintaskbar=yes contextmenu=no selection=no innerborder=no /><object id='shellwindow' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shellwindow.putproperty('" & signature & "',document.parentWindow);</script>""")
do
if proc.status > 0 then exit function
for each shellwnd in createobject("Shell.Application").windows
set createwindow = shellwnd.getproperty(signature)
if err.number = 0 then exit function
err.clear
next
loop
end function
This script will display how many loops it took and the value of a variable during the loop, and display the results in 1 message box after the loop is complete.
Dim RateOfChange, roc, watchvariable : roc = 1 : watchvariable = 1
for i=1 to 25
watchvariable = (watchvariable * i) * 16
RateOfChange = RateOfChange & "Iteration[" & roc & "]" & " - Value[" & watchvariable & "]" & vbcrlf
roc = roc + 1
next
'NOTE uncomment this below to activate msgbox.
'msgbox rateofchange
wscript.echo rateofchange
Related
I've been trying to figure out this issue for 3 days now and I want to hurt myself.
I built a little utility to download files from a server. The script simply loops through a list of user-entered serials and appends each into the file url. It seems to perform fine for the most part until it hits a large file. "Large" being the third serial which is the one and only test case of 500mb I've encountered. The first two are less than 20mb. The smaller files download fine, but the larger file throws a "Not enough memory resources are available to complete this operation." error. I have 16gb of ram (barely utilized) and more than enough storage space.
Here's the really strange part, if I only attempt to download the 500mb file (enter only the last serial), sometimes it works. I cannot conclude what the cause is.
I've included a heavily stripped version of my code. I thought pulling pieces out might resolve the issue or at least shed some light, but it persists. I'd be grateful to anyone that can help me resolve this.
To recreate, copy my script below into a text file and rename extension from .txt to .hta. To use, enter the 3 serials below (including commas) into the text box and click download. The script creates the directory "C:\Downloads" and places downloaded files within:
Serials:
BLES01294,BCES00510,BLUS30109
My hta script:
<!DOCTYPE html>
<!-- saved from url=(0014)about:internet -->
<html style="display: inline-block;" id="mainHTML">
<head>
<meta http-equiv="x-ua-compatible" content="ie=9"/>
<title>Download Tool</title>
<!--Styles defined for doc (end)-->
<!--Scripts to control app window size, position, and behavior (start)-->
<script language="VBScript">
window.resizeTo 500,300
screenWidth = document.parentwindow.screen.availwidth
screenHeight = document.parentwindow.screen.availheight
posLeft = (screenWidth - 800) / 2
posTop = (screenHeight - 600) / 2
window.moveTo posLeft, posTop
</script>
<!--Scripts to control app window size, position, and behavior (end)-->
<!--Features of app window (start)-->
<HTA:APPLICATION ID="download tool"
APPLICATIONNAME="download tool
version="ver.2020.4.13"
CAPTION="yes"
BORDER="thin"
BORDERSTYLE="none"
ICON=""
CONTEXTMENU="yes"
MAXIMIZEBUTTON="no"
MINIMIZEBUTTON="yes"
NAVIGABLE="no"
SCROLL="no"
SCROLLFLAT="no"
SELECTION="no"
SHOWINTASKBAR="yes"
SINGLEINSTANCE="yes"
SYSMENU="yes"
WINDOWSTATE="normal">
</head>
<!--Features of app window (end)-->
<body style="display: inline-block;" id="mainBody" >
<div id="Menu" style="display: inline;"><br>
<center>
<span style="display:inline-block;" id="Span_APIText">
<center>
<Span style="display: inline-block;">
<span >
<textarea style="width:70%;" class="apitextarea" name="txtPS3SerialEntry" rows=6 id="txtPS3SerialEntry"/></textarea>
</span>
<span id="Span_Buttons2" style="display: inline-block;">
<br><br><button id="GetGameDataBtn" title="Browse for download directory" onclick="dataValidation()"><br>Download</button>
</span>
</span>
</center>
</span>
</center>
</div>
</div>
</body>
</html>
<script language="VBScript">
'=================================================
Function dataValidation()
'on error resume next
noBlanks = ""
EntryTest = trim(ucase(document.getelementbyID("txtPS3SerialEntry").value))
if EntryTest = "" then
alert "No valid API numbers found in list"
exit function
elseif EntryTest <> "" then
document.getelementbyID("txtPS3SerialEntry").value = replace(EntryTest,",",vblf)
chkBlankLines = split(document.getelementbyID("txtPS3SerialEntry").value,vblf)
else
chkBlankLines = split(document.getelementbyID("txtPS3SerialEntry").value,vblf)
end if
for i = 0 to Ubound(chkBlankLines)
If Len(trim(chkBlankLines(i))) > 0 then
noBlanks = noBlanks & chkBlankLines(i) & vbcrlf
End If
Next
if noBlanks = "" then
alert "No valid API numbers found in list"
exit function
Else
document.getelementbyID("txtPS3SerialEntry").value = trim(noBlanks)
End If
chkNumeric = split(document.getelementbyID("txtPS3SerialEntry").value,vblf)
call getFiles()
end function
'========================================================
Sub ccSleep(seconds)
set oShell = CreateObject("Wscript.Shell")
cmd = "%COMSPEC% /c ping -n " & 1 + seconds & " 127.0.0.1>nul"
oShell.Run cmd,0,1
End Sub
'============================================================
Function ConvertSize(byteSize)
dim Size
Size = byteSize
Do While InStr(Size,",") 'Remove commas from size
CommaLocate = InStr(Size,",")
Size = Mid(Size,1,CommaLocate - 1) & _
Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate)
Loop
Suffix = " Bytes"
If Size >= 1024 Then suffix = " KB"
If Size >= 1048576 Then suffix = " MB"
If Size >= 1073741824 Then suffix = " GB"
If Size >= 1099511627776 Then suffix = " TB"
Select Case Suffix
Case " KB" Size = Round(Size / 1024, 1)
Case " MB" Size = Round(Size / 1048576, 1)
Case " GB" Size = Round(Size / 1073741824, 1)
Case " TB" Size = Round(Size / 1099511627776, 1)
End Select
ConvertSize = Size & Suffix
End Function
'========================================================================
'Main Function Start
'========================================================================
function GetFiles()
'on error resume next
Set fso = CreateObject("Scripting.FileSystemObject")
path = "c:\Downloads" 'fso.BuildPath("c:\Downloads","")
If NOT fso.FolderExists(path & "\") then
fso.CreateFolder(path & "\")
end if
arrStr = split(ucase(document.getelementbyID("txtPS3SerialEntry").value),vbLf)
APICount = Ubound(arrStr)
for i = 0 to Ubound(arrStr)
API = trim(arrStr(i))
if API <> "" then
Set IE = CreateObject("internetexplorer.application")
IE.Visible = false
IE.Navigate replace("https://a0.ww.np.dl.playstation.net/tpl/np/{game_id}/{game_id}-ver.xml","{game_id}",API)
Do While IE.Busy or IE.ReadyState <> 4: ccSleep(1): Loop
Do Until IE.Document.ReadyState = "complete": ccSleep(1): Loop
on error resume next
ie.document.getelementbyid("overridelink").click
on error goto 0
Do While IE.Busy or IE.ReadyState <> 4: ccSleep(1): Loop
Do Until IE.Document.ReadyState = "complete": ccSleep(1): Loop
'============================================================
id = API
'============================================================
'Grab xml elements from site
for each a in ie.document.getelementsbytagname("package")
ps3ver = a.getattribute("ps3_system_ver")
url = a.getattribute("url")
strFileSize = convertsize(a.getattribute("size"))
ver = a.getattribute("version")
strFileName = mid(url,instrrev(url,"/")+1)
'============================================================
filename = "c:\Downloads\" & strFileName
msgbox "Getting file: " & strFileName & " (" & strFileSize & ")"
Set xHttp = createobject("Microsoft.XMLHTTP")
Set bStrm = createobject("Adodb.Stream")
xHttp.Open "GET", url, false
xHttp.Send
'on error resume next
with bStrm
.type = 1 '//binary
.open
.write xHttp.responseBody
.savetofile filename, 2 '//overwrite
.close
end with
'on error goto 0
'----------------------------------------------------------------
Next
end if
Next 'APICount
ie.quit
end function
'========================================================================
</script>
I'm looking for a bit of code to get an HTA to restart from the beginning. I have seen a forum on this site that creates an HTA that calls a .vbs and cyclically restarts, but I'm looking for hopefully a line or 5 or code that will start an HTA from the beginning.
What I could do is have the script re-open the HTA with the shell.run command and then close it, but is there a cleaner way to do this?
Here is a complete example showing how we can use Location.Reload(True) to reload the HTA file
The good password is 9999
<HTML>
<HEAD>
<TITLE></TITLE>
<HTA:APPLICATION
APPLICATIONNAME="Access to the system © Hackoo © 2015"
BORDER="THIN"
BORDERSTYLE="NORMAL"
ICON="Explorer.exe"
INNERBORDER="NO"
MAXIMIZEBUTTON="NO"
MINIMIZEBUTTON="NO"
SCROLL="NO"
SELECTION="NO"
SINGLEINSTANCE="YES"/>
</HEAD>
<META HTTP-EQUIV="MSThemeCompatible" CONTENT="YES">
<BODY TOPMARGIN="1" LEFTMARGIN="1"><CENTER><DIV><SPAN ID="ONSCR"></SPAN></DIV></CENTER></BODY>
<SCRIPT LANGUAGE="VBScript">
Option Explicit
Dim Title,ws,Voice,ErrorMsg,WelcomeMsg,MyGoodPassword,Password,Temp,Tests,ProcessEnv,UserName
Title = "Access to the system © Hackoo 2015"
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
Set ProcessEnv = Ws.Environment("Process")
UserName = ProcessEnv("USERNAME")
Temp = WS.ExpandEnvironmentStrings("%Temp%")
Tests = Temp &"\Tests.txt"
'------------------------------------------------------------------------------------
Sub window_onload()
CenterWindow 280,180
Call PasswordForm()
Call TextFocus
Dim Count : Count = 0
If Not objFSO.FileExists(Tests) Then
Dim Logfile : Set Logfile = objFSO.OpenTextFile(Tests,2,True)
Logfile.writeline Count
Logfile.Close
end If
Call Kill("Explorer.exe")
Call DisableTaskMgr()
End Sub
'------------------------------------------------------------------------------------
Sub CenterWindow(x,y)
Dim iLeft,itop
window.resizeTo x,y
iLeft = window.screen.availWidth/2 - x/2
itop = window.screen.availHeight/2 - y/2
window.moveTo ileft,itop
End Sub
'------------------------------------------------------------------------------------
Sub PasswordForm()
Self.document.title = "Access to the system © Hackoo 2015"
Self.document.bgColor = "DarkOrange"
ONSCR.InnerHTML="<center><FONT COLOR=""#FFFFFF"" SIZE=""+1"" FACE=""VERDANA,ARIAL,HELVETICA,SANS-SERIF"">Type your Password</FONT><br><br><input type=""password"" name=""PasswordArea"" size=""20"" onKeyUp=""TextFocus""><P>"_
&"<input type=""Submit"" STYLE=""HEIGHT:25;WIDTH:190"" value=""Access to the system"" name=""run_button"" onClick=""CheckPassword"">"
END Sub
'------------------------------------------------------------------------------------
Sub CheckPassword
Dim NB_Tests_MAX : NB_Tests_MAX = 3
Dim Readfile,Count,NB_Tests_Remaining,Logfile,Controle,Command,Executer,MsgNumbTests,MsgReboot
Set Voice = CreateObject("SAPI.SpVoice")
ErrorMsg = "ATTENTION ! ! ! "& vbcr &"The Password is Wrong ! "& vbcr &"Try Again !"
WelcomeMsg = "Welcome again "& DblQuote(UserName) &" in your System !"
MyGoodPassword = "9999"
Set Readfile = objFSO.OpenTextFile(Tests,1)
Count = Readfile.ReadAll
Readfile.Close
Controle = True
While Controle
Count = Count + 1
NB_Tests_Remaining = NB_Tests_MAX - Count
Set Logfile = objFSO.OpenTextFile(Tests,2,True)
Logfile.writeline Count
Logfile.Close
If PasswordArea.Value <> MyGoodPassword Then
Voice.Speak ErrorMsg
ws.Popup ErrorMsg,"1",Title,0+16
MsgNumbTests = "ATTENTION !!! "&vbcr&"Bad Password and NB°of TESTS is " & Count &"."&vbCr&_
"The remaining number of tests is "& NB_Tests_Remaining
Voice.Speak MsgNumbTests
MsgBox MsgNumbTests,48,Title
Sleep(1)
Location.Reload(True)
end if
If PasswordArea.Value = MyGoodPassword Then
If objFSO.FileExists(Tests) Then objFSO.DeleteFile Tests,True
Controle = False
Voice.Speak WelcomeMsg
ws.Popup WelcomeMsg,"1",Title,0+64
Call Launch("Explorer.exe")
Call EnableTaskMgr()
Self.Close
Exit Sub
End If
If Count = NB_Tests_MAX Then
If objFSO.FileExists(Tests) Then objFSO.DeleteFile Tests,True
Voice.Speak "The computer will reboot in 30 seconds !"
MsgReboot = "The Limit number of tests is reached ! "&vbcr& "The computer will Reboot in 30 seconds !"
MsgBox MsgReboot,48,"The Limit number of tests is reached ! "
Command="cmd /c Shutdown.exe -r -t 30 -c " & chr(34) & "The computer will reboot in 30 seconds !" & chr(34)
Executer = WS.Run(Command,0,False)
window.close
End If
Exit Sub
wend
End Sub
'----------------------------------------------------------------------------------
Sub TextFocus
PasswordArea.Focus
End Sub
'----------------------------------------------------------------------------------
Sub Kill(Process)
Dim Ws,Command,Execution
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Taskkill /F /IM "&Process&""
Execution = Ws.Run(Command,0,False)
End Sub
'----------------------------------------------------------------------------------
Sub Launch(Process)
Dim Ws,Command,Execution
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Start "&Process&""
Execution = Ws.Run(Command,0,False)
End Sub
'-----------------------------------------------------------------------------------
'------------------------------EnableTaskMgr----------------------------------------
Sub EnableTaskMgr()
Dim WshShell,System
System="HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\"
Set WshShell=CreateObject("WScript.Shell")
Wshshell.RegWrite System, "REG_SZ"
WshShell.RegWrite System &"\DisableTaskMgr", 0, "REG_DWORD"
End sub
'------------------------------------------------------------------------------------
'-----------------------------DisableTaskMgr-----------------------------------------
Sub DisableTaskMgr()
Dim WshShell,System
System="HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\"
Set WshShell=CreateObject("WScript.Shell")
Wshshell.RegWrite System, "REG_SZ"
WshShell.RegWrite System &"\DisableTaskMgr", 1, "REG_DWORD"
End sub
'--------------------------------------------------------------------------------------
Sub Sleep(intNumSecs)
' Because WScript.Sleep () is not available in HTA
' scripts, invoke a VBScript file to do the waiting.
Dim strScriptFile, strCommand, intRetcode, objWS
If intNumSecs <= 0 Then Exit Sub
Set objWS = CreateObject ("WScript.Shell")
strScriptFile = "%temp%\wait" & intNumSecs & "seconds.vbs"
strCommand = "cmd /c ""echo WScript.Sleep " & intNumSecs * 1000 & " >" & strScriptFile & _
"&start /wait """" wscript.exe " & strScriptFile & """"
intRetCode = objWS.Run (strCommand, 0, True)
If intRetCode = 0 Then Exit Sub
End Sub
'---------------------------------------------------------------------------------------
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'---------------------------------------------------------------------------------------
</SCRIPT>
In referring to a comment by #MCND, to restart a script, simply implement
location.reload True
After whatever event you want to use
I was hoping someone would be able to proved me some direction. I would like to set an application launcher I have created to require a password to be closed. Thank you for any assistance you are able to offer.
But here is some incomplete code to show you my purpose.
Set objShell = CreateObject("Wscript.Shell")
dim password
password=InputBox("Please Enter Password:","3 - Tries Left")
if password = ("9999") then
dim correct correct =MsgBox("Correct Password!",64,"correct")
objShell.Run("shutdown /m shutdown -r -f -t 0")
Else
dim again
again =MsgBox("Incorrect Password! Do You Want To Try Again?",53,"Incorrect Password!")
If again = 4 Then
dim password2
password2=InputBox("Please Enter Password:","2 - Tries Left")
if password2 = ("9999") then
dim correct2
correct2 =MsgBox("Correct Password!",64,"correct")
Sorry ! I was unable to post all of the code.I just need to know what to put to close the existing window. I think telling it to close MSHTA.EXE will work.
Try this HTA and i hope that can did the trick.
NB : The Password is 9999 and of course you can change it at this line
MyGoodPassword = "9999"
<HTML>
<HEAD>
<TITLE></TITLE>
<HTA:APPLICATION
APPLICATIONNAME="Access to the system © Hackoo © 2015"
BORDER="THIN"
BORDERSTYLE="NORMAL"
ICON="Explorer.exe"
INNERBORDER="NO"
MAXIMIZEBUTTON="NO"
MINIMIZEBUTTON="NO"
SCROLL="NO"
SELECTION="NO"
SINGLEINSTANCE="YES"/>
</HEAD>
<META HTTP-EQUIV="MSThemeCompatible" CONTENT="YES">
<BODY TOPMARGIN="1" LEFTMARGIN="1"><CENTER><DIV><SPAN ID="ONSCR"></SPAN></DIV></CENTER></BODY>
<SCRIPT LANGUAGE="VBScript">
Option Explicit
Dim Title,ws,Voice,ErrorMsg,WelcomeMsg,MyGoodPassword,Password,Temp,Tests,ProcessEnv,UserName
Title = "Access to the system © Hackoo 2015"
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("wscript.Shell")
Set ProcessEnv = Ws.Environment("Process")
UserName = ProcessEnv("USERNAME")
Temp = WS.ExpandEnvironmentStrings("%Temp%")
Tests = Temp &"\Tests.txt"
'------------------------------------------------------------------------------------
Sub window_onload()
CenterWindow 280,180
Call PasswordForm()
Call TextFocus
Dim Count : Count = 0
If Not objFSO.FileExists(Tests) Then
Dim Logfile : Set Logfile = objFSO.OpenTextFile(Tests,2,True)
Logfile.writeline Count
Logfile.Close
end If
Call Kill("Explorer.exe")
Call DisableTaskMgr()
End Sub
'------------------------------------------------------------------------------------
Sub CenterWindow(x,y)
Dim iLeft,itop
window.resizeTo x,y
iLeft = window.screen.availWidth/2 - x/2
itop = window.screen.availHeight/2 - y/2
window.moveTo ileft,itop
End Sub
'------------------------------------------------------------------------------------
Sub PasswordForm()
Self.document.title = "Access to the system © Hackoo 2015"
Self.document.bgColor = "DarkOrange"
ONSCR.InnerHTML="<center><FONT COLOR=""#FFFFFF"" SIZE=""+1"" FACE=""VERDANA,ARIAL,HELVETICA,SANS-SERIF"">Type your Password</FONT><br><br><input type=""password"" name=""PasswordArea"" size=""20"" onKeyUp=""TextFocus""><P>"_
&"<input type=""Submit"" STYLE=""HEIGHT:25;WIDTH:190"" value=""Access to the system"" name=""run_button"" onClick=""CheckPassword"">"
END Sub
'------------------------------------------------------------------------------------
Sub CheckPassword
Dim NB_Tests_MAX : NB_Tests_MAX = 3
Dim Readfile,Count,NB_Tests_Remaining,Logfile,Controle,Command,Executer,MsgNumbTests,MsgReboot
Set Voice = CreateObject("SAPI.SpVoice")
ErrorMsg = "ATTENTION ! ! ! "& vbcr &"The Password is Wrong ! "& vbcr &"Try Again !"
WelcomeMsg = "Welcome again "& DblQuote(UserName) &" in your System !"
MyGoodPassword = "9999"
Set Readfile = objFSO.OpenTextFile(Tests,1)
Count = Readfile.ReadAll
Readfile.Close
Controle = True
While Controle
Count = Count + 1
NB_Tests_Remaining = NB_Tests_MAX - Count
Set Logfile = objFSO.OpenTextFile(Tests,2,True)
Logfile.writeline Count
Logfile.Close
If PasswordArea.Value <> MyGoodPassword Then
Voice.Speak ErrorMsg
ws.Popup ErrorMsg,"1",Title,0+16
MsgNumbTests = "ATTENTION !!! "&vbcr&"Bad Password and NB°of TESTS is " & Count &"."&vbCr&_
"The remaining number of tests is "& NB_Tests_Remaining
Voice.Speak MsgNumbTests
MsgBox MsgNumbTests,48,Title
Sleep(1)
Location.Reload(True)
end if
If PasswordArea.Value = MyGoodPassword Then
If objFSO.FileExists(Tests) Then objFSO.DeleteFile Tests,True
Controle = False
Voice.Speak WelcomeMsg
ws.Popup WelcomeMsg,"1",Title,0+64
Call Launch("Explorer.exe")
Call EnableTaskMgr()
Self.Close
Exit Sub
End If
If Count = NB_Tests_MAX Then
If objFSO.FileExists(Tests) Then objFSO.DeleteFile Tests,True
Voice.Speak "The computer will reboot in 30 seconds !"
MsgReboot = "The Limit number of tests is reached ! "&vbcr& "The computer will Reboot in 30 seconds !"
MsgBox MsgReboot,48,"The Limit number of tests is reached ! "
Command="cmd /c Shutdown.exe -r -t 30 -c " & chr(34) & "The computer will reboot in 30 seconds !" & chr(34)
Executer = WS.Run(Command,0,False)
window.close
End If
Exit Sub
wend
End Sub
'----------------------------------------------------------------------------------
Sub TextFocus
PasswordArea.Focus
End Sub
'----------------------------------------------------------------------------------
Sub Kill(Process)
Dim Ws,Command,Execution
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Taskkill /F /IM "&Process&""
Execution = Ws.Run(Command,0,False)
End Sub
'----------------------------------------------------------------------------------
Sub Launch(Process)
Dim Ws,Command,Execution
Set Ws = CreateObject("Wscript.Shell")
Command = "cmd /c Start "&Process&""
Execution = Ws.Run(Command,0,False)
End Sub
'-----------------------------------------------------------------------------------
'------------------------------EnableTaskMgr----------------------------------------
Sub EnableTaskMgr()
Dim WshShell,System
System="HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\"
Set WshShell=CreateObject("WScript.Shell")
Wshshell.RegWrite System, "REG_SZ"
WshShell.RegWrite System &"\DisableTaskMgr", 0, "REG_DWORD"
End sub
'------------------------------------------------------------------------------------
'-----------------------------DisableTaskMgr-----------------------------------------
Sub DisableTaskMgr()
Dim WshShell,System
System="HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System\"
Set WshShell=CreateObject("WScript.Shell")
Wshshell.RegWrite System, "REG_SZ"
WshShell.RegWrite System &"\DisableTaskMgr", 1, "REG_DWORD"
End sub
'--------------------------------------------------------------------------------------
Sub Sleep(intNumSecs)
' Because WScript.Sleep () is not available in HTA
' scripts, invoke a VBScript file to do the waiting.
Dim strScriptFile, strCommand, intRetcode, objWS
If intNumSecs <= 0 Then Exit Sub
Set objWS = CreateObject ("WScript.Shell")
strScriptFile = "%temp%\wait" & intNumSecs & "seconds.vbs"
strCommand = "cmd /c ""echo WScript.Sleep " & intNumSecs * 1000 & " >" & strScriptFile & _
"&start /wait """" wscript.exe " & strScriptFile & """"
intRetCode = objWS.Run (strCommand, 0, True)
If intRetCode = 0 Then Exit Sub
End Sub
'---------------------------------------------------------------------------------------
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'---------------------------------------------------------------------------------------
</SCRIPT>
I am able to load url on NEW window and change the web title with the following:
Set IE = CreateObject("InternetExplorer.Application")
set WshShell = WScript.CreateObject("WScript.Shell")
IE.Navigate "http://www.google.com"
IE.Visible = True
While IE.Busy
Wend
While IE.Document.ReadyState <> "complete"
Wend
IE.Document.Title = "yoyo"
Is there any way to make it open new tab instead of new window? How?
Another senarion I am trying is with:
set WshShell = WScript.CreateObject("WScript.Shell")
url= "http://google.com/"
Set objShell = CreateObject("Wscript.Shell")
objShell.Run(url)
IE.document.title = "yoyo"
This allow me to open new tabs on the same browser (IE) but I cannot change the page title...
Any help will be highly appreciated!
Look here:
' VB Script Document
' http://stackoverflow.com/questions/22821984/looking-for-a-way-to-load-url-in-new-tab-and-change-the-title-once-done
'
option explicit
On Error Goto 0
Dim strMyUrl : strMyUrl = "http://www.avg.com" 'strMyUrl = "http://www.jysk.cz" 'strMyUrl = "https://www.google.cz" 'strMyUrl = "www.microsoft.com"
Dim strWTitle : strWTitle = "yoyo"
Dim strResult : strResult = WScript.ScriptName '
Dim WshShell : Set WshShell = WScript.CreateObject( "WScript.Shell")
Dim IE : Set IE = Nothing
Dim oIE : Set oIE = Nothing
Dim intWExist, BrowserNavFlag, intButton, sRetVal
intWExist = FindIE( strMyUrl, oIE) 'look for MSIE window'
set IE = oIE
Select Case intWExist
Case 3
''' MSIE window found, URL match, window title match
''' (not implemented yet)
Case 2
''' MSIE window found, URL match
Case 1
''' MSIE window found, no URL match
''' BrowserNavFlag = 65536 ' navOpenNewForegroundTab
BrowserNavFlag = 2048 ' navOpenInNewTab
IE.Navigate2 strMyUrl, CLng( BrowserNavFlag), "_blank"
Case Else
''' MSIE window not found
Set IE = CreateObject( "InternetExplorer.Application")
BrowserNavFlag = 1
IE.Navigate strMyUrl ', CLng( BrowserNavFlag)
End Select
IE.Visible = True
While IE.Busy
Wscript.Sleep 100
Wend
While IE.Document.ReadyState <> "complete" 'Or IE.ReadyState <> 4
Wscript.Sleep 100
Wend
'intButton = WshShell.Popup( "watch how MSIE title change", 1)
If intWExist <> 1 Then
intWExist = 2
Else
Set oIE = Nothing
Set IE = Nothing
strResult = strResult & vbNewLine & vbTab & "FindIE() pass # 2"
Wscript.Sleep 2000 'additional time for the Navigate2 method'
intWExist = FindIE( strMyUrl, oIE) 'get right object for newly created tab'
If intWExist = 2 Then
set IE = oIE
End If
End If
If intWExist = 2 Then
IE.Document.Title = strWTitle
sRetVal = "done"
Else
sRetVal = "'IE.Document.Title = strWTitle' - not renamed"
End If
Set IE = Nothing
Wscript.Echo strResult & vbNewLine & sRetVal ' propagate result
Private Function FindIE( ByVal sUrl, ByRef oObj)
' parameters
' sUrl (input) string
' oObj (output) object
' returns
' 0 = any MSIE window not found - or found but not accessible
' 1 = a MSIE window found
' 2 = 1 and address line match
' 3 = 2 and title match (not implemented yet)
Dim ww, tpnm, tptitle, tpfulln, tpUrl, tpUrlUnencoded
Dim errNo, errStr, intLoop, intLoopLimit
Dim iFound : iFound = 0
Dim shApp : Set shApp = CreateObject( "shell.application")
With shApp
For Each ww In .windows
tpfulln = ww.FullName
strResult = strResult & vbNewLine & ww.Application & vbTab & tpfulln
If Instr( 1, Lcase( tpfulln), "iexplore.exe", 1) <> 0 Then
If iFound > 0 Then
Else
Set oObj = ww
End If
tptitle = "x x x" : tpUrl = "" : tpUrlUnencoded = ""
intLoopLimit = 100 ' to look for attributes max. intLoopLimit/10 seconds
intLoop = 0
While intLoop < intLoopLimit
intLoop = intLoop + 1
On Error Resume Next
tpnm = typename( ww.document)
errNo = Err.Number
If errNo <> 0 Then
'error if page not response (yet)'
errStr = "Error # " & CStr( errNo) & " " & Err.Description
Wscript.Sleep 100
Else
iFound = 1
intLoopLimit = intLoop ' end While..Wend loop and preserve loop counter
tptitle = ww.document.title
tpUrl = ww.document.URL
tpUrlUnencoded = ww.document.URLUnencoded
errStr = tpnm
End If
On Error Goto 0
Wend
strResult = strResult & vbTab & errStr & " " & CStr( intLoop)
If Instr( 1, Lcase( tpnm), "htmldocument", 1) <> 0 then
strResult = strResult & vbTab & tptitle _
& vbNewLine & vbTab & tpUrl _
'& vbNewLine & vbTab & tpUrlUnencoded
If Instr( 1, Lcase( tpUrl), Lcase( sUrl), 1) <> 0 Then
Set oObj = ww
iFound = 2
strResult = strResult & vbTab & "!match!"
' looking for all matching MSIE URLs
' this may take considerable time amount
' to speed up script running, uncomment next line "exit for"
' exit for
Else
End If
End If
Else
' a program reports the same shell.application property as "iexplore.exe"
' i.e. "explorer.exe"
' i.e. "HTML preview" in some editors
' etc.
End If
Next
End With
Set shApp = Nothing
strResult = strResult & vbNewLine & Cstr( iFound)
FindIE = iFound
End Function
I have a third party application that invokes a vsbscript file for certain operations. I would like to put up a user prompt with a choice of options, either a drop down list or checkbox or some such. However, all I can find is the input box option.
I don't think HTAs are an option in my case (unless there is a way to call them from a .vbs file?)
My other thought was some sort of ActiveX control, but I can't locate a built-in one that would be available by default on WindowsXP/Vista.
Anybody have any ideas on how I could accomplish this?
The simple answer is, you really can't. Tmdean's solution is the only way I can think of either. That said, you can spruce up the input box so it doesn't look horrible. Give this a run, I don't think it's an epic fail:
Dim bullet
Dim response
bullet = Chr(10) & " " & Chr(149) & " "
Do
response = InputBox("Please enter the number that corresponds to your selection:" & Chr(10) & bullet & "1.) Apple" & bullet & "2.) Bannana" & bullet & "3.) Pear" & Chr(10), "Select Thing")
If response = "" Then WScript.Quit 'Detect Cancel
If IsNumeric(response) Then Exit Do 'Detect value response.
MsgBox "You must enter a numeric value.", 48, "Invalid Entry"
Loop
MsgBox "The user chose :" & response, 64, "Yay!"
If you would like to use an hta for this it can be done like this.
The VBScript:
Set WshShell = CreateObject("WScript.Shell")
'Run the hta.
WshShell.Run "Test.hta", 1, true
'Display the results.
MsgBox "Return Value = " & getReturn
Set WshShell = Nothing
Function getReturn
'Read the registry entry created by the hta.
On Error Resume Next
Set WshShell = CreateObject("WScript.Shell")
getReturn = WshShell.RegRead("HKEY_CURRENT_USER\Volatile Environment\MsgResp")
If ERR.Number 0 Then
'If the value does not exist return -1
getReturn = -1
Else
'Otherwise return the value in the registry & delete the temperary entry.
WshShell.RegDelete "HKEY_CURRENT_USER\Volatile Environment\MsgResp"
End if
Set WshShell = Nothing
End Function
Then design the hta as desired, and include the following methods
'Call this when the OK button is clicked.
Sub OK_Click
For Each objradiobutton In Opt
If objradiobutton.Checked Then
WriteResponse objradiobutton.Value
End If
Next
window.Close
End Sub
'Call this when the Cancel button is clicked.
Sub Cancel_Click
WriteResponse("CANCEL")
window.Close
End Sub
'Write the response to the registry
Sub WriteResponse(strValue)
Set WshShell = CreateObject("WScript.Shell")
WshShell.RegWrite "HKEY_CURRENT_USER\Volatile Environment\MsgResp", strValue
Set WshShell = Nothing
End Sub
I used a group of radio buttons named "Opt" to make a choice, but you could use any controls you would like.
Because hta's cannot return values, this will create a temperary registry entry. If you are not comforatable messing with the registry, you could also write the result to a temperary text file.
This approach is nice because you can design the hta any way you like, rather than using the supplied inputbox and choosing numbers (thats so DOS).
This could also be nice if you expanded the hta to create itself based on arguments passed to it, like passing in a title, a message to display, an array of options, a set of buttons. That way you could use the same hta any time you needed to get input from the user.
You can use DialogLib to create forms with dropdowns and checkboxes. DialogLib is still in it's ealy stages, but is's allready quite usefull: http://www.soren.schimkat.dk/Blog/?p=189
Try WshShell.Popup. Depending upon your data that may work for you...
Otherwise you could investigate PowerShell.
One option is to script Internet Explorer. You can use VBScript to launch IE and load a local HTML file, and attach a VBScript sub to a form's submit button (or any other JavaScript events), which can then close the IE window as part of its execution.
You can launch an HTA from a VBScript.
Set shell = CreateObject("WScript.Shell")
shell.Run "Test.hta"
EDIT
Since you have full control of the VBScript, could you make the 3rd party VBScript simply call your HTA? You could put the UI and whatever processing code inside of the HTA.
As an example of #TmDean's suggestion, there's this class that I sometimes use which scripts IE (well, it scripted IE6; I haven't tried the more recent incarnations.)
class IEDisplay
'~ Based on original work by Tony Hinkle, tonyhinkle#yahoo.com
private TEMPORARY_FOLDER
private objShell
private objIE
private objFSO
private objFolder
private strName
private streamOut
private objDIV
private numHeight
private numWidth
private numTop
private numLeft
private sub Class_Initialize()
Dim strComputer
Dim objWMIService
Dim colItems
Dim objItem
Dim arrMonitors( 10, 1 )
Dim numMonitorCount
Set objShell = WScript.CreateObject("WScript.Shell")
Set objIE = CreateObject("InternetExplorer.Application")
strComputer = "."
Set objWMIService = GetObject( "winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery( "Select * from Win32_DesktopMonitor")
numMonitorCount = 0
For Each objItem in colItems
arrMonitors( numMonitorCount, 0 ) = objItem.ScreenHeight
arrMonitors( numMonitorCount, 1 ) = objItem.ScreenWidth
numMonitorCount = numMonitorCount + 1
Next
numHeight = arrMonitors( 0, 0 )
numWidth = arrMonitors( 0, 1 )
Set objFSO = CreateObject("Scripting.FileSystemObject")
TEMPORARY_FOLDER = 2
set objFolder = objFSO.GetSpecialFolder( TEMPORARY_FOLDER )
strName = objFSO.BuildPath( objFolder, objFSO.GetTempName ) & ".html"
WriteFileU strName, Join( Array( "<HTML><HEAD><TITLE>Information</TITLE></HEAD>", _
"<BODY SCROLL='NO'><CENTER><FONT FACE='arial black'> <HR COLOR='BLACK'>", _
"<DIV id='MakeMeAnObject'></DIV>", _
"<HR COLOR='BLACK'></FONT></CENTER></BODY></HTML>" ), vbCRLF ), WF_CREATE
numTop = 0
numLeft = 0
end sub
Sub Init( strPosition )
'NW, N, NE, W, CENTRE, E, SW, S, SE
Select Case strPosition
Case "NW"
numTop = 0
numLeft = 0
Case "N"
numTop = 0
numLeft = ( numWidth / 2 ) - 250
Case "NE"
numTop = 0
numLeft = numWidth - 500
Case "W"
numTop = ( numHeight / 2 ) - 55
numLeft = 0
Case "CENTRE"
numTop = ( numHeight / 2 ) - 55
numLeft = ( numWidth / 2 ) - 250
Case "E"
numTop = ( numHeight / 2 ) - 55
numLeft = numWidth - 500
Case "SW"
numTop = numHeight - 110
numLeft = 0
Case "S"
numTop = numHeight - 110
numLeft = ( numWidth / 2 ) - 250
Case "SE"
numTop = numHeight - 110
numLeft = numWidth - 500
Case Else
numTop = 0
numLeft = 0
End Select
SetupIE( strName )
Set objDIV = objIE.Document.All("MakeMeAnObject")
end sub
private sub Class_Terminate()
'Close IE and delete the file
objIE.Quit
'~ optionally you may want to get rid of the temp file
end sub
public sub Display( strMsg, numMillisec )
objDIV.InnerHTML = strMsg
WScript.Sleep numMillisec
end sub
Private Sub SetupIE(File2Load)
objIE.Navigate File2Load
objIE.ToolBar = False
objIE.StatusBar = False
objIE.Resizable = False
Do
Loop While objIE.Busy
objIE.Width = 500
objIE.Height = 110
objIE.Left = numLeft
objIE.Top = numTop
objIE.Visible = True
objShell.AppActivate("Microsoft Internet Explorer")
End Sub
end class
here is the missing (from the original posting) WriteFileU function
Const WF_APPEND = 1
Const WF_CREATE = 2
Const WF_FOR_APPENDING = 8
Const WF_FOR_WRITING = 2
Const WF_CREATE_NONEXISTING = True
Const CONST_READ = 1, CONST_WRITE = 2, CONST_APPEND = 8
Const AS_SYSTEMDEFAULT = -2, AS_UNICODE = -1, AS_ASCII = 0
Sub WriteFileU( sFilename, sContents, nMode )
Dim oStream
If nMode = WF_APPEND Then
Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_APPENDING, WF_CREATE_NONEXISTING, AS_UNICODE )
ElseIf nMode = WF_CREATE Then
Set oStream = oFSO.OpenTextFile( sFilename, WF_FOR_WRITING, WF_CREATE_NONEXISTING, AS_UNICODE )
Else
STOP
End If
oStream.Write sContents
oStream.Close
Set oStream = Nothing
End Sub
and then as an example of it's use
set i = new IEDisplay
a = array("NW", "N", "NE", "W", "CENTRE", "E", "SW","S","SE")
for each aa in a
i.init aa
i.display "Here in " & aa & " of screen", 1000
next
Now that's not immediately useful (especially are there are a pile of calls to my own utility routines in there) but it gives a framework. By modifying what HTML is stored, you could add support for listboxes etc.
I know this is eleven years too late, but it sounds like this would be more along the lines of what the original request would be looking for:
Sub CustomMsgBox(msg)
Dim ie, Style, FormExit
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
While ie.ReadyState <> 4: WScript.Sleep 100: Wend
ie.Toolbar = False
ie.StatusBar = False
ie.Width = 450
ie.Height = 275
ie.document.body.innerHTML = "<title>Choose a Color</title><p class='msg'>Choose an option:</p>" & "<input type='radio' id='myRadio' name='colors' value='red'>Red</br><input type='radio' id='myRadio' name='colors' value='yellow'>Yellow</br><input type='radio' id='myRadio' name='colors' value='blue'>Blue"
Set Style = ie.document.CreateStyleSheet
Style.AddRule "p.msg", "font-family:calibri;font-weight:bold;"
ie.Visible = True
ie.Quit
End Sub
This code worked for me in an HTA file (that I opened from VBS using WScript.Shell Run). The trick was to get the data back to VBS which I accomplished by having HTA create an XML file that VBS read.
Sub CopySelect(sSrcId, sTargetId)
Dim oTarget: Set oTarget = document.getElementById(sTargetId)
Dim oSrc: Set oSrc = document.getElementById(sSrcId)
Dim j, n, o
oTarget.length = 0
For j = 0 to oSrc.length - 1
Set o = oSrc.options(j)
Set n = document.createElement("option")
n.text = o.text
n.value = o.value
oTarget.add n
Next
End Sub