Underpants
Reputation: 131
VBScript script progress notification
I'm a VBScript novice, writing a script that will be parsing large input file(s) and will likely take several minutes run time to complete processing. I need a way to alert users that the script is running without error during this long processing time. My first thought was to present a msgbox for every 1000th record processed (e.g. "script has successfully processed 1000 records so far.") Haven't quite cracked the proper way to code an incrementer that will conditionally trip a msgbox every Nth record (or determined if there's a better way to achieve my end goal). Any ideas?
Upvotes: 13
Views: 39681
Answers (7)
Antoni Gual Via
Reputation: 763
A very simple solution if your script runs in console and is not outputting text to it. You can issue
wscript.stdout.write "*"
every x records. It's Simple but unbounded, you can end with several lines of *. If you issue texts to the console, precede and end them with vbcrlf so they don't get mixed with the asterisks.
Upvotes: 1
Mark Llewellyn
Reputation: 51
An HTML.HTA file like the one used below (created and started in the temp directory by the VBS script) can be used to display contiguous square blocks via a Webdings text string updated using "g" characters.
The HTML.HTA reads dynamically from a temporary text file, getting the prompt from the first line and the length of the progress bar from the second. HTML escape sequences can be added to both lines.
Option Explicit
Dim fso,wsh,temppath,tempname,temphta,fhta,z,result,info,progress,aFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set wsh = wscript.CreateObject("wscript.Shell")
temppath = fso.GetSpecialFolder(2).ShortPath & "\"
tempname = fso.GetTempName
temphta = tempname & ".hta"
Call CreateHTAFile
'CREATE THE INFO FILE
'********************
Set fhta = fso.OpenTextFile(temppath & tempname,2,True)
fhta.WriteLine "<i>Loading..."
fhta.WriteLine "g"
fhta.Close
'START THE HTML.HTA
'******************
wsh.run (temppath & temphta),0,false
'PUT YOUR PROCESSES HERE THAT UPDATE THE PROGRESS BAR VIA THE UPDATE SUB
'***********************************************************************
Randomize
for z= 1 to 20
Update "<i>Loading files...",replace(space(z), " ", "g")
wscript.sleep(int(rnd*500) + 1)
next
for z= 1 to 20
Update "<i>Checking disks...",replace(space(z), " ", "g")
wscript.sleep(int(rnd*500) + 1)
next
for z= 1 to 20
Update "<i>Looking at pictures of your wife!", "<b><font style=""color:yellow; font-family:Wingdings;"">" & replace(space(z), " ", "J")
wscript.sleep(int(rnd*500) + 1)
next
'KILL THE HTML SESSION BY GIVING IT A SINGLE "X"
'***********************************************
Update "x",""
'TIDY-UP
'*******
do while fso.FileExists(temppath & temphta)
Set aFile = fso.GetFile(temppath & temphta)
aFile.Delete
loop
wscript.sleep(200)
do while fso.FileExists(temppath & tempname)
Set aFile = fso.GetFile(temppath & tempname)
aFile.Delete
loop
wscript.quit
'***********************************
Sub Update(info,progress)
Set fhta = fso.OpenTextFile(temppath & tempname,2)
fhta.WriteLine info
fhta.WriteLine progress
fhta.Close
End Sub
'***********************************
Sub CreateHTAFile
Set fhta = fso.OpenTextFile(temppath & temphta,2,True)
fhta.WriteLine "<html>"
fhta.WriteLine "<body bgcolor=red style=""overflow:hidden;"">"
fhta.WriteLine "<div style=""color:aqua; font-family:Arial;"" id=""info""></div>"
fhta.WriteLine "<div style=""color:yellow; font-family:Webdings;"" id=""progressbar""></div>"
fhta.WriteLine ""
fhta.WriteLine "<script language=""VBScript"">"
fhta.WriteLine ""
fhta.WriteLine "Sub Update"
fhta.WriteLine ""
fhta.WriteLine " On Error Resume Next"
fhta.WriteLine ""
fhta.WriteLine " Dim objFSO, infoFile, progressbarFile"
fhta.WriteLine ""
fhta.WriteLine " Set objFSO = CreateObject(""Scripting.FileSystemObject"")"
fhta.WriteLine ""
fhta.WriteLine " Set infoFile = objFSO.OpenTextFile( """ & temppath & tempname & """,1,1)"
fhta.WriteLine ""
fhta.WriteLine " document.getElementById(""info"").innerHTML = infoFile.ReadLine"
fhta.WriteLine " document.getElementById(""progressbar"").innerHTML = infoFile.ReadLine"
fhta.WriteLine ""
fhta.WriteLine " width = 420 : height = 80"
fhta.WriteLine " window.resizeTo width, height"
fhta.WriteLine " window.moveTo screen.availWidth\2 - width\2, screen.availHeight\2 - height\2"
fhta.WriteLine ""
fhta.WriteLine " if LCase(document.getElementById(""info"").innerHTML) =""x"" then"
fhta.WriteLine " Window.Close"
fhta.WriteLine " end if"
fhta.WriteLine ""
fhta.WriteLine " window.setTimeout ""Update()"", 100, ""VBScript"""
fhta.WriteLine ""
fhta.WriteLine " If Err.Number <> 0 Then"
fhta.WriteLine " Window.Close"
fhta.WriteLine " End If"
fhta.WriteLine ""
fhta.WriteLine "End Sub"
fhta.WriteLine ""
fhta.WriteLine "Sub Window_OnLoad"
fhta.WriteLine " window.resizeTo 0, 0"
fhta.WriteLine " window.setTimeout ""Update()"", 100, ""VBScript"""
fhta.WriteLine "End Sub"
fhta.WriteLine ""
fhta.WriteLine "</script>"
fhta.WriteLine ""
fhta.WriteLine "<hta:application id=""oHTA"""
fhta.WriteLine " border=""none"""
fhta.WriteLine " innerborder=""yes"""
fhta.WriteLine " caption=""no"""
fhta.WriteLine " sysmenu=""no"""
fhta.WriteLine " maximizebutton=""no"""
fhta.WriteLine " minimizebutton=""no"""
fhta.WriteLine " scroll=""no"""
fhta.WriteLine " scrollflat=""yes"""
fhta.WriteLine " singleinstance=""yes"""
fhta.WriteLine " showintaskbar=""no"""
fhta.WriteLine " contextmenu=""no"""
fhta.WriteLine " selection=""no"""
fhta.WriteLine "/>"
fhta.WriteLine "</html>"
fhta.close
End Sub
'***********************************
However, I usually use HTML-HTA to show a daisywheel clock using this base64 encoded gif:
Option Explicit
Dim fso,wsh,temphtml,temppath,fhta,objWMIService,objProcess,strComputer,colProcesses
Set fso = CreateObject("Scripting.FileSystemObject")
Set wsh = wscript.CreateObject("wscript.Shell")
Call Clock
wscript.sleep(5000) '...REPLACE THIS WITH YOUR LENGTHY PROCESS
Call KillClock(temphtml)
wscript.quit
'***********************************
Sub Clock
temppath = fso.GetSpecialFolder(2).ShortPath & "\"
temphtml = fso.GetTempName & ".hta"
Set fhta = fso.OpenTextFile(temppath & temphtml,2,True)
Call CreateHTA
wsh.run (temppath & temphtml),0,false
End Sub
'***********************************
Sub KillClock(FileName)
On Error Resume Next
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colProcesses = objWMIService.ExecQuery("SELECT * FROM Win32_Process")
For Each objProcess in colProcesses
If InStr(objProcess.CommandLine,FileName) > 0 Then
objProcess.Terminate(0)
End If
Next
wsh.run ("cmd /c del " & temppath & temphtml),0,false
End Sub
'***********************************
Sub CreateHTA
fhta.WriteLine "<html>"
fhta.WriteLine "<script language=""VBScript"">"
fhta.WriteLine "window.resizeTo 0, 0"
fhta.WriteLine "Sub Window_OnLoad"
fhta.WriteLine "width = 75 : height = 75"
fhta.WriteLine "window.resizeTo width, height"
fhta.WriteLine "window.moveTo screen.availWidth\2 - width\2, screen.availHeight\2 - height\2"
fhta.WriteLine "End Sub"
fhta.WriteLine "</script>"
fhta.WriteLine "<hta:application id=""oHTA"""
fhta.WriteLine "border=""none"""
fhta.WriteLine "caption=""no"""
fhta.WriteLine "contextmenu=""no"""
fhta.WriteLine "innerborder=""yes"""
fhta.WriteLine "scroll=""no"""
fhta.WriteLine "showintaskbar=""no"""
fhta.WriteLine "/>"
fhta.WriteLine "<img src=""data:image/gif;base64,R0lGODlhPAA8APcfAAAAACQAAEgAAGwAAJAAALQAANgAAPwAAAAkACQkAEgkAGwkAJAkALQkANgkAPwkAABIACRIAEhIAGxIAJBIALRIANhIAPxIAABsACRsAEhsAGxsAJBsALRsANhsAPxsAACQACSQAEiQAGyQAJCQALSQANiQAPyQAAC0ACS0AEi0AGy0AJC0ALS0ANi0APy0AADYACTYAEjYAGzYAJDYALTYANjYAPzYAAD8ACT8AEj8AGz8AJD8ALT8ANj8APz8AAAAVSQAVUgAVWwAVZAAVbQAVdgAVfwAVQAkVSQkVUgkVWwkVZAkVbQkVdgkVfwkVQBIVSRIVUhIVWxIVZBIVbRIVdhIVfxIVQBsVSRsVUhsVWxsVZBsVbRsVdhsVfxsVQCQVSSQVUiQVWyQVZCQVbSQVdiQVfyQVQC0VSS0VUi0VWy0VZC0VbS0Vdi0Vfy0VQDYVSTYVUjYVWzYVZDYVbTYVdjYVfzYVQD8VST8VUj8VWz8VZD8VbT8Vdj8Vfz8VQAAqiQAqkgAqmwAqpAAqrQAqtgAqvwAqgAkqiQkqkgkqmwkqpAkqrQkqtgkqvwkqgBIqiRIqkhIqmxIqpBIqrRIqthIqvxIqgBsqiRsqkhsqmxsqpBsqrRsqthsqvxsqgCQqiSQqkiQqmyQqpCQqrSQqtiQqvyQqgC0qiS0qki0qmy0qpC0qrS0qti0qvy0qgDYqiTYqkjYqmzYqpDYqrTYqtjYqvzYqgD8qiT8qkj8qmz8qpD8qrT8qtj8qvz8qgAA/yQA/0gA/2wA/5AA/7QA/9gA//wA/wAk/yQk/0gk/2wk/5Ak/7Qk/9gk//wk/wBI/yRI/0hI/2xI/5BI/7RI/9hI//xI/wBs/yRs/0hs/2xs/5Bs/7Rs/9hs//xs/wCQ/ySQ/0iQ/2yQ/5CQ/7SQ/9iQ//yQ/wC0/yS0/0i0/2y0/5C0/7S0/9i0//y0/wDY/yTY/0jY/2zY/5DY/7TY/9jY//zY/wD8/yT8/0j8/2z8/5D8/7T8/9j8//z8/yH/C05FVFNDQVBFMi4wAwEAAAAh+QQEBwAfACwAAAAAPAA8AAAI/wD/CRxIsKDBgwLtIVzIsKHDg60itnpIseJDe61IkWql0KLHjwJtkSKTcSLIkxRLjjR50J6tjigPvnyJMKLGiDW3bCEDM+ZAlxhtIRRJciNCnZt2+jTYambPgRk1GjVIRueWpEsL2mq3VahBkRnbtPt6VYrOsVkHzuzKdONNg1aTbklbkGNTl1pXToV61SpauiGBcqwbtQ1LgVb7AtbKFShBlXv/Vd1kdstTwC67eg2p93DiTaQWf+XKlSVklkitMjR82OCvmQxtOYWakaRJWzqlJG09sE2CJBK28B7IFTZCjEFZXu6LFKKEJFKeSyGD8BdpW01pMn152SCpvq1tRf9P8hu47oVONW/+ub6hvS2hCW75/bw+9IZdGwdtH5MM/STAkWdWd1+5dBdQ/HnUinT/JSCFFMMtJFhQxcUkRYBS0CdFfB9lFhSBFj2n4SYgUtSYdjGR4uCDf/nkUosWbigaXRHOaONHv4gWEWut8CjReh7KJmRTFdKVAABIJqkkkgnEJ9uHHJ2IHGASLGklkxwh11Vm1+FFlxRXLvnbRC9xVKaWW1IZ5pIQBobdWicOZuSRdAJQZwIOlnjjnnxmlWCfFBm31GuAnfmnRb+8eGhF2H24KEWJPinnRzOd2FhMkV7HnUeGaqbnQ5GaWZyX+HlqZk85epRqQnA+qaehoz6v9dKqDeVIa0iN2SUbQ2ZueZmi9txakK0oEoTgmQRyKahWvcJk6z+rRrqrTF0eiiB6yg6U6LYE5UeqQdcy9GqXj2nZbXEwivbkskH2JFtxj/qkK1fdUkgrgu18WyiwBSFoj6yjxguSdY0WK5Cul+VnsJ9rJTxhge8KrCBywxmYGbWz0eVUhJku/I+ik/r54XGn/rnup5z+e2ijNX7sMZ8NSwxouVnOnPK0Nlu0KV0BAQAh+QQFBwABACwAAAAAPAA8AAAI/wADCBxIsKDBgwL/IVzIsKHDg/9s2VP4sKJFh7/sSbRF8aLHjwH+tdI4EaRJixkD2GrV0eCvf79OInz56yVChSTtzWzFs6XMhAIlzrQ3kuPBX6RItSJl62fBlO1CQmwlkeVBnklHOjXYVOdRnSSvkiKzNObWgRqjai0oUqNVgr+WKlV6Fm47oQHMDsxY1KctpWSUeq1LsJVKgwqrtoyblS7hgrbuSt0L1uhAuYHfPj5oTy/JyB1XzqW6uSDJkYN/3aXaETPPwU9rwmTYefbBqk3zCvzcjiJPsoKPttqyiaxPgrhhQx482K/crAhJbZleXPnAiFq9Hve49LVBMtOJT/8nZR1t1QBe9Q7E+/AfmdxBpW8SL97wQrAD70a1bdLryvAAjvfQRp9FZplM8ok33yakfESVfuhpBhJ4ARJn30fJHSaTPQpa+NNp5YEUHlOEwffTFo6VpuKKLFq03VakHdaULTQep9FVm0kgxY489rjjFhcGFUA7RBGV34snJZGAkksm4GQSEiQhBRn/UGSgeUayt1WUUiQgBZRSKimFjuSht5F+uaEW5FZd7uhlmzpKKQUpOAmkVWToBWDYjXXpyKOfX445ZVQtFmooYUh6RFZpa5pkCwAJbGGiUzU6JQEAmCZR5lZF/tQGpqAmIMFaF8X12Z0n/ZIAqKxG2uhCfKXShRalUkDKaqZbhGiaUHdt9FNrq94K6agDSsYnQRol+pRPmwR7qxSTIifQXccid6eyNkXLobOQSkEoYkNGuyupecFk7nq7IdROl6BK8ZA9umqZEEcHBmVsdEtKkWtD6hlUpGEdxVqvVjEitJSuFV1Y3kj9povwTxsZaB2hx/naMGHkLldvhOE+3N+Vk+1l7KQEMrziq2amZeNKYT12pbjsvajTfozCO5VK7Vysp6+IyrucniH7O5KyH92IJGk+78bzoQUBzDSGGz/tkM1Se6SzSQEBACH5BAUHAAEALAEAAQA7ADsAAAj/AAMIHEiwoEGDtuzZOsiwocOHECNKnEixokWIvyTag/jvIseMBxPaamerI0OF/0B6ZNjK5EGSCRn+E2nP5UqDrRQeVGgvJ0OROVXeJNjuYc6FNgX+Giky6dCFPWsaVDhyY8F/VElaHUrw39FWJQ3C/Kk1LFeEPBcSjNlu60CeAWKefTkygFuvOgsyTeh2bsG0LtX6JKiQZDuhfpUWBRv3Lc21aaXKFOhUoC21DX+1PWoyYavGlnsyrSywFSmwiKdiDhm371/PcBGaJtXmdOWNJAMUdZj3IU2npILPPt0Qc2zVFOUONN2KTPDajBumNbzQrEebwk9rb/U5ItjCducy/3dOyjl31w5tDdat/OLz7afRQ6SqU/7Ef+S1W/domDRF7qe1dFZ7Q8WXWGKrHahgRSBl9MtGCQ4YAGNgVfhaa58VldtG9l20xYebfCjiFiFuQYpaG32WVl1aJUaiiCHGKCJxb+WUoWW6pXYTjCPyuEVLsImUW2kdejiijCWa2B2OdtH0mF9kbELKJlGa+CEpSha54JZc+qWjRRlFONR6QyUgBSkD8rTkUElIIYEUAl4ElGhiVpRAEne6uUUA/v0U2UK7rSSFFGbe2aYU4UV0WU/L9bbjoIWa+SYZfT7IFHiJUlaRHZhhmYQEbeYpxZ7S+WRjQjZ9ydAvEgBA6kCkuMyZxKd5bmHfpaiqVidBv2wAwK8JoGmQrJ+Oelt4x/G6nn+/SPHrr1K4tpGsUpBR5H6EZauUPQ+qREoCzyZARkNbjEpKn/5dZtiFBrX6bBK76jaUQtENFBNKsD7766sL5rSRUyoWtIW+Sax5oHoh4YYTuMDaenBUBDapU1Kk6Busgp+N5BSgoBHmLrRaTgSUdOqi92248VaUFp8Jq1hZEu8afNODR51UXZ2tJHCnBIGmuatmuklmUKwXd4ncZUZfBDSZSVeEbdMaYZVYQAAAIfkEBQcAAQAsAQABADoAOwAACP8AAwgcSLCgwYO27Nk6yLChw4cQI0qcOLEVxYsYBy5c+PBfxoj2Gv5qF5Hjx4O/7LWyF/KgwpYMUyY0eXLgv422PBr8ZTEAzYIk2+Ws6XLlL4MKEzZUKBAm0YK2lBYcKTLAyp5PoQZ1KZVr06wFne4k6bPgTaEkdYIVmBKrWp9MxQYIKXQtxX9YDbZaaO+t3Zst26k1+TPhyp8G/x1taOuXX5sWoxIMmVDuy4aAHT8eqJJtw3YqNwv0WDfAY8czbZU+aPEyQ46iCeKNqTJk7b4uFaLlu1g2RbFtFR5WKBrwzMv2etc8a/hl5dimfVrc65xoaqGqn0v8x/RqQugQowr/rf3948tW4EFmJ36SO9+sx9NHlD8xJ3278/Hrz6pYrvW9Akm2UQBHKbeaQAeCRQYpDDboIIMrIbgQWZOhZxcprWCoIYZkZBhZWXXZcpWE/p3UBoMndrgghB2KNZx4kl2Y4YYeQrgXdx5xN9d3feG2logiqpTdXtrtZ+SRAyn3VEpg/dNGiebldZIdUmwB1npLbrHJFluQMldGPCVFkpQZbckll15SFFx2Ad6XWCtcbmnmFmRMVBtn5S1nCylnankmgA5R9150SappVoZzmpkma7qt5xdeyUG0mBRItUJGol2KFmFXUN350BYJJCGFFFJyd2mfpCAW1mZJvbTYBrBuzLHBaFtIEaoEVia255YMihaSkgQZFuBAUgBgbAIttTJqqJQyhFc7gB4EHnlOSWAsAMgORIattm4B5T/ggskUhQMlcW22AsGZRAJSJEEGlCc1epC1xzpFiq1JSNCsXTwhSCix1ybhlC21rkupmxCdxxC92LoohQSikroWkzMdZG69BtV6a65ZueYfw+gSpCy3+y5JZkHFYmzQtu1KAe9dxy0csH/21Mqlqh/l2FDKDTPU6Mt2pRwqkhmREWoCHBNtJ5dSLKq0nXMh7FBAAAAh+QQFBwABACwAAAAAOwA8AAAI/wADCBxIsKDBg7/s/TrIsKHDhxDtQZxIsaJAWwJbSbTIsaPAhQEwehw58Nc/h/ZstQvZcCFIkg1tnTxoy5Y9jSgDbITJUKRBm0AbruSJUOLOnzdtFvVJtGArlTVnElQ69GcAjUybCkxZtefBfzW3StV61WYrmhmPDlzZDuNLsmmz6oRqVaJSuAXN2lO7tWBCjVjxOs2YFyrTlHwFD1SJmCDXqQHatk1M0CTMlHcHgrU3FvHZhpttvp3KFaPMgxI/8wRrUWK7lAFGx55M0ZbqqWbpyl280ra9rjD/jTW90jPlgrDj/pPdEehZlZEFjo0p2TlZrL1TToeYO2Rbnnbb7v/2+Px4RayNtQIf+S8wXOaK48ufT3bhcpamFe9NqLC/5QAn+fZUVebxBJR41VX3z15UHXgVV/CNBJRhmFV4UVUUAlVgczc11iFgnM0l0mSAQYeXcx3WJF56Os0VUmNuwbWZdjohJtF29OWoo0ebaRWWj5g1ZQsppNw2UkIP4sRTK2S0UiRMerU4XkVDOklkkVM+pNdZGzr0y5CktBEmkU1mWVJSD77ok5kOtXelk1Zy9yJOmWWUACkcjeZkk0TCeRx02B20BQAAJGDmP39ssQmeBJ20J5N9MucgjU4RaikZDpGxxaZbMNSKlUy2guNFyf0kgaWF7iRBAKsORMYmiirMOt6nRb7m0GkHkYIqAIwKlEQCUkghEkacbmEkQStGeGsCqApLkBS/SkEQKbFuQQqbIw1q6Z3PAgssZLFKQcqoMLXCrKVbHCVFAkkEy1QrnMKKLUdSoJrEsRJEi1wAsG5KSpcVtYFqAp0WtO7Bcm3aL171WpoEX+u2K21B//QLa69E2XJuoRgPJEW+wMplS7HpamXPucBS5u3EBlF78bwTbXHwsQId3O54rxYJ8ERV7tUQyAU3pBG58X2cRMk7VhQsy0nzLNCTTZ+HV0AAACH5BAUHAAEALAAAAAA7ADwAAAj/AAMIHEiwoMGD/xIeXMiwocOHtto9nEix4sBW9mxZ3Mhx4L+OIDvaytgqgL2F/36lDInw18lfC3+1G6nx4UeWBmsuzBhA4smD9kqaxGmwVUSdBGXSRGgL40iYRAeOxOgQ48+cAYRGzTnT4D+qSAkG1Qh1q8CjJ68OzDhT7dm2tm6aXUu1oNKedtsKdLv1n86wGccS9MtzLsK1QE1encq3Y1mGY7vuPar169SoJ8keDjw0gMt/9uROHdkQqq2wHrU2ftvU3uPEexlK1HtYamavpCmultq5IecApOO+5ljWJWOMRm1qDJo1qGu5ITnTpD0xME22Ua+XnAl6I0/muzfO/3QaGiTo6ZivR/1YeGt4kX2HG55Pv/5El/g9zz8NnH9cpCRFhlZE9qWVm1p+wdVVZMC915FWXc0kkVhG+aTVUfTVxNhp6sXWWWDWzQWVc6TZc9VNCaWo4oqGqRgAi9DZJ2NBTfU1ly1bJCHBVr/Ix5EtpEiRAAAAOPiQcUY21IqQRDaJU0oGtlcRjkM2SWQCW7Bk3IBJekaKBFY2mcQWXXpFmFEkPlUVmGECgKVWjnk0WpS7kZFEmwlIQcpiUmRZkUqDTXfaTKgNxGSTCSSxCWpJ5AnnQT22QkobXkmXUVwHHQrAmCYapKOOCQz0GEx+SUoKKaid51xdBpEhRaNbsODq0RZ55ulnAGTkmqtUpJAh6aMeWefaQq200s5uEiShrBQEbbHJFtB6RIqkZJDSUIovgiSFkBL0eRUZ0D5LEJDTTmsfKYkmsS2cz4ZbWSvV/lomRbZIkawECWxSELjtqmXPtPECSxStn24RlrPQGjyYqb8atmSe6u65b7hbTCgqwKcWGhKtQvYJbLvOokYuvAKD9Mu26jJ7EL/Q8hXUqZJqzNE/23Z7a0EIOytwUzDPq6SzZKwGbsKNfVVstn2RFuNApCC8KEoK+Vjf0FugOiNHkj5r7dUbGS0r1xRha1ZAAAAh+QQFBwABACwAAAAAOwA7AAAI/wADCBxIsKDBgwHsIVzIsKHDhbYUPpxIseGvhK0qatxY0FYrexE5iiR4EeGvdhj/jVwZQOXBf7baRbTlkCbLgTBBgjx4MkBMlwVh4ryJ01bMkAZhykyIEKRMiUQHejSJ0l4roAMvtpoZtWg7nSUJelQIVaxVpl2lBkBpsGfZrE8jhu36zypYgkoDZDzINq3BnW9nkj0Y069Bmxmh/tu6tKjhhYsHSwVs06fTiXMX/sJqcO9QyQR3mgT81uxHuS9PX2W4mOEv0JX/Vv4IkSJnga8HemYoWLBPrLcdBj/qszFDpx5pGo0tMixxtQ9d2j0tWqTEjBE/2gvOOmF2oipVV/8f+f3xTZ1RmYPvWtq8+/d+W5GRIoE+/foSEkjRnzZzy8r/XGTPfgAUaOCBBUqRlk6C0UadUQQiKKGCXf3yEWM02XWUPQMmIOGEC/pmnHGkbJFEEgmgqGKKCfAHn0C+DUTWjBzW2J5hCnH34nvq7eiQhVtQ6ONDv9gS5H67jdQaS7aQIsV+SUiQRHoxVvRLiVLqp5+QLMnUmH8LtRKkllIk8SQpPVppGXEg6QjjJvSZmSJ9m+C1EWe0eQkjREFmaaYEeuFFBhkVBRiUb7SF+eSc9ZHylpibbNFGQyoFeJtOefL2ZJRSkLKaWCVuISopAhkawGa4wWRUey4ZZVxB9gS5ucVaCIm5RaSb2GThVq2UFKCXtuiInrBJihWpqJt41gopZJBCalEgGVWTSP+EGimhUnnqKV5jPWWeLWQcWyeopLSBZmirRuQmtaGOWtCyy56LE1lbpbmSrbge5qynb6lq17oaXSmqqC115GmzzNXl3Y3kIXurevEu+1JI6ka12K2iFpsQGfGql9OGXbVy7LP6luvoxE+B2Zy2aTa5b5r2vGavdTO3Aq/GQQG8oMloDfnjzT5TxGBXAQEAIfkEBQcAAQAsAAAAADsAOwAACP8AAwgcSLCgwYMBbNmzh7Chw4cQDTIM8CuixYsP/yVkOBGjx48gQ4pk2MqeLYe/OopEqLJgSYEtXVJcafBXu4QI/9m6+ZLlyZg0AwAlqPBhyVYagw7U2W5nRYRNY+pUWFRpQZMBbh7EyrLVzpNWBzKMCnZpq6wsCSYNK9DWzqxrxWZ9KtZrU7YF/5V0O1OgXntnfQ61SLfhV60DbfUs2DQwSocbACSQUNYg2Mp1Bxc+GJdoEgCgAWzZDPMo14GFbbo93fDuQVtJEoSWTGpzSqqDhX51/DpqQ3sSZodOwFuoR8wBdALG6nUwKSmyhQOgvLKj8rOAYRr/vUkCEOkJtiD/x6hcMUfF2yG22hIbfO6HVKN6FUjaKHThpIKa7Pj+9/PQSVi1l1K2dAdAcSuNJ1I7W1j1T2d4RSjhhJZtsYUUG2AoxUBSSNAhhW0xpFBKFT0nQRJSoIiiFCwmcWKEPE1E1V4LkZHiiZMlEFsCCdyI134BYEejYzZCl6KLKuIYYFh6fbXcW4udJcWFLLLoYZUS7odbVTiJddKXbXUJol9jlpmTmSAl1SCaFmlEioWb5EfTP6rNGQAZW2xi4ZpKNZbmWXvCuQUZK9FpnIz9+WULnnk2amF6ITFl3k0jPvTLm47CKWdYJi2GGGeY6tnoJga1gmBDdBoq1n7YUYWQLZjuwEkqZoqRQoaCBf2iqlphejWgRGToqaeYZpFCSivHLkXmVQ7t5yyowRIKYULHkpGsX79kqytBgP1kWJiCoYrssZtSpGVcgX26FaTHVXutX6ZhBiSF/xhLbmVatlOYXmhxyZapZCBbXJO+FeSWumFdSq6pEq02nkmuMSmwtQj+VVKiCduLLGczTpvQTRHr10rA5RJ1HlBa4lXru3k1dypMTkocJKpf+avWT/WJ9I89HusWM5sRlcca0KimTHTQ8yoVEAAh+QQFBwABACwAAAAAOwA7AAAI/wADCBxIsKDBgwF+BfiHsKHDhxALKoxIsaLFAO0uatw40BbHjwJ/tdmwpdXEgv9stbPVyt7DfydBCrSVBAAACRkP2rJlz6NDjwxldkxgE8CWh+1iHmwllKAtokWZalSokmfTgVKKApDic2DKlSsRSk14VSApqDZJ6XTZkGfLsgO3aJXAtuPKVkG9esyptGkrtEYNVq270Kq9sXAFytWKeGZPggpbVQUJs23WolIKHm7Yk7DBvAfbSJFCpiEprQnULmxcsCpoiSERbpIgJQHp1wHsLbZJl+xC318xOmTYGaFuKUkkJLHd5jUZtEm6IuQp3euvnMIR/pqdJHmS2kcLyv9N4tm49gAeJbOtPrDVFinKbSdIHl5gq00XpVMNKxC7Q1Kj1YacbZmVd9FXKg102D8GCgaggPMpt4FMGVGXG2sUvVebd/WBhBhuFbk32ndXdcaeRvaQAZ9qQvnXlD34JSbjjDTWiFIrZJBCRo47krGFjz7ClVJuhlllS0r//OPeJls02aQkWzDJZIdC/XJYT0x5RF1OSjoppZNeUimTkj2F1c6V6h1JCilgRunmlGLKVJ1HV05my5oBbALnlFIKKdWWVVHH1mMBvGVfmScK5ZJnDdroaG6PcqRkG5Ee2Eora2JYqU6Y5ojnmIAm+hKmpGCKI6ZNVZgRoREpqWOnpErM9iJGbvUEIkEpmZppplbNONlPa7ZRao6sWanRa1uid2Vfq5W6ZqmGetXTkRDlxWx/FhroKhmmQirRWztB9EuvayUo6qWlkosrovaUV9lAd0Fk4kc7rcRqSp3FRKeoAjF4a0TGsmoXS4RhWaiN1PFEmJKCQraqjcQRKdGVDb1lz7Uf4WsYSm4ZN1mjHBm708XllmuvkIA2mFOD7JaFoMBetWShWBJfldLMOtH6EMgcddaoxaI+xu9GDF5LnKYE8exoUptupHTTHT1dUUAAACH5BAUHAAEALAEAAAA7ADsAAAj/AAMIHEiwoEGDtmy1snWwocOHEB+SkbJFSquIGDNqlJIAQJItGkOKLGirIwAAUkaqJPgr4a9/B0ueBJDAIcwAN1cW/FWRor2D9kx6tInzl86DUqRISBlzJsqGRgO0Y3iUpZQkCZLGTDKzpsF/tqZWbSgBK8WcAmWeTNLQXlhbP8cObJU0QRIJBoPOxLszwEK3cg1yvLqFalqnbAv+/NkqbuCBdbOSIqiW5s63Yh8TnJhksGG9J5kKzLn4KNqDZbOCPDwz8cC4F3W2THia4OCssUFbHh3Wr72oB2sT/Edqi3FShg1i7SwFZivmWgUCLv31JVzgBf+R2bSFO5lW2AXS/x0soR3RqZnzDgwbXvp248YDkAJvcOlkjY55u/1pPkD+gsV1B98WyOWUnEpg7RfAWwo61Ipx3HF3nC3CjbTYXwkBFpE9ZAwoIYEHinShf401JlI7xX24CRljpedfVQJu8d9Izu0X4kgBBmbjY7bcN5aGms2o2ZBEPpRgQkgmudCQv/xkFFhQjiZdK6R8R8qVWGap2T9LLmSePbElRyWV85VJZRvzDcmQiWlRBeZvrVBp5XdkVFkmi0OaOBV/bvoHJpmAllmmZk3CFVtjCr0ZIkNwNfrikPb8Zs8/P8ElUHtFZtpQhZqGBGRVnCLYqJAq/RQqRpQa+qlsb+G0EliGWs16o4gXgXlpSLBOhWhjpGpUqKJTnTrar6PCJaxG5rl5UagJmqhodpjaFF6juroVbEONvuUoSb0e9FJtNmY2q7UJtTNpXp8Z+dKCNzr2pkPUuhqToskJ9+aq82JK6bqbYtjfpaMaVOtDDHUL0ZGIEmTrpwXPmqdbsa337EBcvnusShmySXGjESumUKcXJXSQi5Q5S2TFfj1KGbno2upwp2nBjO2eN1L178hFVorvQDRjCzGh/hWMrXi9WkrkpJy+K/NKqi6tknkXO02SZgEBACH5BAUHAAEALAEAAAA6ADsAAAj/AAMIHEiwoEGD/wLY+3WwocOHEBv+arWFFKmIGDNq3CJFghSNIEMalCIliQSRKAcm/PcrYUMpCZKQdPjLli2GKQ22IkOKjK2DtmAKbdgmSQIpW37mVElmy5ZNFw+WPNrQlgQACQAkibpU4CanTpUWFErV4BYAaLG26jqQzNevXAnClPmxoK2saZOwJQiW41qCQU0m2TIyrdq9bb86DeByoGCPBdvgRVsXscCnmEfGnEkwSdqY7SwPJNV3i72BrUpKMEmQjGEAhEUPfOuUjNyYkAXa8pz3tEiWLB1SdPoVtVCZA89+jkuwcWOCrVqRamXr+cBfionrngp9staGLBcG/9fZ0yJ1614xb/l7UDnaBOxV/rL3s50t382lS29jsQ36prFB1ApeAV4XAHX22UMdUNKZZ9F0z0mHX0SkJBCagdSdpuB96Ol2YE/7TdcKTijh9899rZwWGn0TVhXdgzuJ2GFGJ9IXmi0JihURfSHCiNh9QLaokX7TsaVhivd1tV98OeGYpGxQRinllFL+Y+WVwC1kz4xdzefllvMFwNA/9NlEHYI28Sibkwqe5qRCArGoEItJtqmjaCgqiBCQCqWYYZ6yLZhiAHnq+FOZLPqJomgn5mifQPYlyJiGdLJIH5cp/aQpnIROSuWnoCKGaaikWuYSjpbJadmTez3KGEgM2bNp352ZlnkjfUOiFuRe+NkpZFVvSkmnfUgudNAvoUm6l0skxgnko8raheujQp76KkRh/hokkg3ZyGdDkWpk00N8XgqUPb86SxB+QTbLZLenkbmUn3btqhOtwk64li3v6raisDa5Ch26dxZa3ZT99onqugoFi6eHB/2Z7qBR0vuQwKSq2dBfrOqE66oBRGuQkwkPJHJOCX0bsboH+dZxl5xW1WbJcZaKWqc2i4txzhKlm1NAAAAh+QQFBwABACwBAAAAOwA8AAAI/wADCBxIsKDBg/Z+2TvIsKHDhw3/2WoVoNVCiBgzYvxFagsZUm00ihxpcMuWTVJIkVw5cpNJkw5/BfjHkqGtibZoHjTpUuVBWye3tJJZs2ArUqRaUTzo8uXBX1uSSJAiZWnRgUmRttJZkOfJg2SkJJCSRIqtqwSPtiFFxirBplt8FqSaZKwUtARtaU16tmvQnWID4yX46yjSpAbhbipoS2xdKVsG5wWZlMzFgV7JdB1rV7LRwyC5BlA8l6xYuZ4FqtVK0GtkgfaiJuhck6Zog3tb9bUFV27YsVIb/rppi6jBXxKRM7R3tC3iil4XB2gsVaqkp6RmA5CiGaEt5jmNT/82TKovwcucqR5vJRaA+7E2LX63KPN2q4/mG5Iim8Bgqy0JuCfgdsvNZ89NB95WkYINbSHFZUAFOKB7KUVkYADg5cRgRn3Z89uEACQhFEYHlvjdTRtmRIoEEg44lkUZ0QReO7bQmB9JZAAAxIRJkHKZSCdieONKLYa4xY8rnYjkSu28V9VgBw42FWqpXWXPklVmKZJtM1X5z5dgfjkTlwMpNN2ZEwXQTpWF4TQdRUt9Z1yNZ1FEo4lYFsXclfIt1A6eSgqEIJyCVhmlQHdOtKeM0zFX0Yl05smSQnRiqOZAQQZAlHklNjqkZIcOJKmWpJbqWYqmQiTRVqBK1ideNzXUWlRhjVKEqkaVdkmSiXe6VdOeA9F460AS7QmjRcNipGSQrEL03XQ2LmScckXRaRGNS234LKKwiSdkshxe+amoNVp6ZkELpRnuuI8mapOl2yIEY0LCFQtbgY42JC5EJfqq4IHYsnsurGsW5K5Bo+IVqq5CPvvjgRbZaiqNBf2CrXcdmlruTwtDay24IukGHsIY+orpoQmzpOi4F/pX0cierdkpY8A6pGiq/gH8qUIyM3yVxSbGN7NBgZ6ak76CwricRDgbdHDTHKoZL9T8Nuot1VVLFhAAOw=="" style=""position:absolute;left:5;top:5;"">"
fhta.WriteLine "</html>"
End Sub
'***********************************Upvotes: 2
Mark Llewellyn
Reputation: 51
Although HTA solutions are effective, keeping the window on top can be a pain. When I need to grab VBS and really make it dance I use a VBS+Powershell+C# script. I can then "splash" status messages directly to the top left of the screen:
Here's the Powershell+C# script:
Add-Type -TypeDefinition @'
using System;
using System.Drawing;
using System.IO;
using System.Threading;
using System.Windows.Forms;
using System.Runtime.InteropServices;
public static class Progress
{
public static int previouswidth_ = 0;
public static int previousprogressBarYOffset_ = 0;
public static Boolean previousshowProgressBar_ = true;
public static void Monitor(string filename_)
{
while(true)
{
try{
using (FileStream fs = new FileStream(@filename_, FileMode.Open, FileAccess.Read, FileShare.ReadWrite))
{ //...FileStream > StreamReader SO WE DON'T LOCK THE FILE
using (StreamReader streamReader = new StreamReader(fs))
{
string info_ = streamReader.ReadLine();
streamReader.Close();
if(info_.Length<=0)
{
try{ File.Delete(@filename_);}catch{} //AN EMPTY FILE WILL END THE SESSION SO IT WILL BE DELETED
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, IntPtr.Zero, null, SMTO_ABORTIFHUNG, 100, IntPtr.Zero);
System.Environment.Exit(1);
}
if( info_.Trim().Substring(0,1) =="-") //A SINGLE - OR -/0 CLEARS THE SCREEN
{
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, IntPtr.Zero, null, SMTO_ABORTIFHUNG, 100, IntPtr.Zero);
//Thread.Sleep(500);
}
else
{
Splash(info_);
}
}
}
}
catch
{ //...OR CLOSE IF THE FILE IS DELETED
SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, IntPtr.Zero, null, SMTO_ABORTIFHUNG, 100, IntPtr.Zero);
System.Environment.Exit(1);
}
Thread.Sleep(100);
}
}
public static void Splash(string infoMSG_)
{
try
{
Boolean showProgressBar_ = true;
string progressMSG_ = "";
string denominator_ = "";
try{ progressMSG_ = new String('g',int.Parse(infoMSG_.Split(' ')[0].Split('/')[0])); } catch{ progressMSG_ = ""; }
try{ denominator_ = new String('g',int.Parse(infoMSG_.Split(' ')[0].Split('/')[1])); }catch{}
if(denominator_=="" || denominator_.Length==0) showProgressBar_ = false;
if(showProgressBar_ != previousshowProgressBar_) SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, IntPtr.Zero, null, SMTO_ABORTIFHUNG, 100, IntPtr.Zero); //Thread.Sleep(500);
previousshowProgressBar_= showProgressBar_;
try{ infoMSG_ = infoMSG_.Substring(infoMSG_.IndexOf(' ',infoMSG_.IndexOf(' '))+1,infoMSG_.Length-infoMSG_.IndexOf(' ')-1); } catch{ infoMSG_ = ""; }
int progressBarYOffset_ = 40;
if( infoMSG_.Length <=0)
{
progressBarYOffset_ = 0;
//IF THE IMAGE DECREASES IN WIDTH, REDRAW THE SCREEN BEFORE DISPLAYING THE SHORTER IMAGE
//...THE PAUSE RELIEVES THE FLASH EFFECT
if(progressBarYOffset_ < previousprogressBarYOffset_) SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, IntPtr.Zero, null, SMTO_ABORTIFHUNG, 100, IntPtr.Zero); //Thread.Sleep(500);
}
previousprogressBarYOffset_ = progressBarYOffset_;
// YOU CAN CENTRE THE DISPLAY, BUT IT'S MORE WORK AND THE TOP-LEFT DISPLAY
// IS LESS ANNOYING AND IS HANDY FOR GENERAL ALERTS
//int x_ = Screen.PrimaryScreen.WorkingArea.Width;
//int y_ = Screen.PrimaryScreen.WorkingArea.Height;
//DETERMINE HOW WIDE THE WINDOW SHOULD BE
var zero = new Bitmap(1, 1);
Graphics g_ = Graphics.FromImage(zero);
Font stringFont = new Font( "Webdings", 14 );
SizeF stringSize = new SizeF();
stringSize = g_.MeasureString(denominator_, stringFont);
int bmpWIDTH_ = (int)(stringSize.Width)+20;
stringFont = new Font( "Arial", 18, FontStyle.Italic );
try{stringSize = g_.MeasureString(infoMSG_, stringFont);}catch{stringSize = g_.MeasureString("", stringFont);}
int infoMSGWIDTH_ = (int)(stringSize.Width)+20;
if(!showProgressBar_) { bmpWIDTH_ = infoMSGWIDTH_; }
else { if(infoMSGWIDTH_ >= bmpWIDTH_) bmpWIDTH_ = infoMSGWIDTH_; }
if( bmpWIDTH_==20 ) bmpWIDTH_=0; //IF WE ONLY HAVE THE OFFSET THEN REMOVE IT
int bmpHEIGHT_ = 40;
//IF WE SWITCH BACK TO <=20 AFTER MORE THEN REPAINT THE SCREEN TO CLEAR THE LAST IMAGE (AND ADD A PAUSE TO REDUCE THE FLASH EFFECT)
if( bmpWIDTH_ < previouswidth_ && previouswidth_ != 0 /*I.E NOT STARTUP*/) SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, IntPtr.Zero, null, SMTO_ABORTIFHUNG, 100, IntPtr.Zero); //Thread.Sleep(500);
previouswidth_ = bmpWIDTH_;
//CREATE THE INFO BAR BITMAP
var BMP = new Bitmap(bmpWIDTH_, bmpHEIGHT_);
Graphics g = Graphics.FromImage(BMP);
g.Clear(Color.Red);
StringFormat drawFormat = new StringFormat();
drawFormat.FormatFlags = StringFormatFlags.DirectionVertical;
Font font = new Font("Arial", 18, FontStyle.Italic);
try{ g.DrawString(infoMSG_,font,new SolidBrush(Color.White),8,10);
} catch{}
//DISPLAY IT
IntPtr hbm = BMP.GetHbitmap();
IntPtr sdc = GetDC(IntPtr.Zero);
IntPtr hdc = CreateCompatibleDC(sdc);
SelectObject(hdc,hbm);
BitBlt(sdc, 0, 0, BMP.Width, BMP.Height, hdc, 0, 0, SRCCOPY);
if(showProgressBar_)
{
//CREATE THE PROGRESS BAR BITMAP
g.Clear(Color.Red);
font = new Font("Webdings", 14, FontStyle.Regular);
g.DrawString(progressMSG_,font,new SolidBrush(System.Drawing.Color.Yellow),10,7);
//DISPLAY IT
hbm = BMP.GetHbitmap();
SelectObject(hdc,hbm);
BitBlt(sdc, 0, progressBarYOffset_, BMP.Width, BMP.Height, hdc, 0, 0, SRCCOPY);
}
//TIDY UP
DeleteDC(hdc);
ReleaseDC(IntPtr.Zero,sdc);
DeleteObject(hbm);
}catch{return;}
}
[DllImport("user32.dll", SetLastError = true)]
private static extern IntPtr SendMessageTimeout(IntPtr hWnd, int Msg, IntPtr wParam, string lParam, uint fuFlags, uint uTimeout, IntPtr lpdwResult);
private static readonly IntPtr HWND_BROADCAST = new IntPtr(0xffff);
private const int WM_SETTINGCHANGE = 0x1a;
private const int SMTO_ABORTIFHUNG = 0x0002;
[System.Runtime.InteropServices.DllImport("user32.dll")]
public static extern IntPtr GetDC(IntPtr hwnd);
[System.Runtime.InteropServices.DllImport("gdi32.dll")]
public static extern IntPtr CreateCompatibleDC(IntPtr hdc);
[System.Runtime.InteropServices.DllImport("gdi32.dll")]
public static extern IntPtr SelectObject(IntPtr hdc, IntPtr hgdiobj);
[System.Runtime.InteropServices.DllImport("gdi32.dll")]
public static extern int BitBlt(IntPtr hdcDst, int xDst, int yDst, int w, int h, IntPtr hdcSrc, int xSrc, int ySrc, int rop);
static int SRCCOPY = 0x00CC0020;
[System.Runtime.InteropServices.DllImport("gdi32.dll")]
public static extern int DeleteDC(IntPtr hdc);
[System.Runtime.InteropServices.DllImport("user32.dll")]
public static extern int ReleaseDC(IntPtr hwnd, IntPtr hdc);
[System.Runtime.InteropServices.DllImport("gdi32.dll")]
public static extern bool DeleteObject(IntPtr hObject);
}
'@ -Language CSharp -ReferencedAssemblies system.drawing, system.windows.forms
[Progress]::Monitor($args[0]);
Now, we could embed this line-by-line in the VBS file for when we create the temporary .ps1 file. However, if you want to use a large C# script this becomes another pain.
So, I drag+drop the Powershell+C# script into this VBS file (Bin2Txt.vbs) to create a compressed, base64 encoded version:
Dim wsh, fso
Set wsh = wscript.CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.fileSystemObject")
If WScript.Arguments.Count > 0 Then
For each arg in WScript.Arguments
path_and_filename = path_and_filename & arg
Next
tokens = Split(path_and_filename, "\")
infilename = tokens(UBound(tokens))
For i=0 To UBound(tokens)-1
path = path & tokens(i) & "\"
Next
else
WScript.Quit
End If
outfilename = infilename & ".txt"
tempfile = fso.GetTempName
'MAKECAB NEEDS THE TRAILING "\" REMOVED FROM path
'*****************************************************
wsh.run ("cmd /c makecab /L """ & left(path,len(path)-1) & """ """ & WScript.Arguments(0) & """ " & tempfile ),0,True
bytes_ = readBytes(path & tempfile)
'MS PUTS A LF ( 0Ah , CHR(10) ) AFTER 72 BYTES (SPEC SAYS 76) ...SO WE'LL TAKE THEM OUT
'*****************************************************
base64_ = """" & Replace(encodeBase64(bytes_), vblf, "") & """"
tempfile_ = fso.GetTempName & ".txt"
set objOutputFile = fso.CreateTextFile(path & outfilename, TRUE)
objOutputFile.WriteLine(base64_)
objOutputFile.Close
if fso.FileExists(path & tempfile) then
Set aFile = fso.GetFile(path & tempfile)
aFile.Delete
end if
wscript.quit
'*****************************************************
private function readBytes(file)
dim inStream
' ADODB stream object used
set inStream = WScript.CreateObject("ADODB.Stream")
' open with no arguments makes the stream an empty container
inStream.Open
inStream.type= 1 'TypeBinary
inStream.LoadFromFile(file)
readBytes = inStream.Read()
end function
'*****************************************************
private function encodeBase64(bytes)
dim DM, EL
Set DM = CreateObject("Microsoft.XMLDOM")
' Create temporary node with Base64 data type
Set EL = DM.createElement("tmp")
EL.DataType = "bin.base64"
' Set bytes, get encoded String
EL.NodeTypedValue = bytes
encodeBase64 = EL.Text
end function
'*****************************************************
private Sub writeBytes(file, bytes)
Dim binaryStream
Set binaryStream = CreateObject("ADODB.Stream")
binaryStream.Type = 1 'adTypeBinary
'Open the stream and write binary data
binaryStream.Open
binaryStream.Write bytes
'Save binary data to disk
binaryStream.SaveToFile file, 1 'adSaveCreateOverWrite
end Sub
The base64 text is then added into the target VBS script (e.g. "Splash.vbs"), which expands it and runs it to create the progress or status messages:
Dim wsh, fso, PS1file_, PROGESSfile_ , Base64file_
Set wsh = wscript.CreateObject("wscript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
'CREATE THE POWERSHELL SCRIPT IN THE TEMP DIRECTORY
Call CreatePS1file
'CREATE THE FIRST PROGESS FILE IN THE TEMP DIRECTORY
Call Update("1/20 Loading...")
'START THE POWERSHELL SCRIPT IN THE BACKGROUND
'wsh.Run ( "powershell -NoLogo -Command ""& '" & PS1file_ & "' '" & PROGESSfile_ & "'"" "),0,false
'***************************************************************************
'PUT YOUR LENGTHY PROCESSES HERE, CALLING THE Update SUB AS THEY PROGRESS:
' 0/0 TO DISPLAY ONLY THE TEXT
' ----------------------------
Update("0/0 Show a single line of text...")
wscript.sleep(3000)
Update("0/0 Or just show the progress bar...")
wscript.sleep(2000)
' x/yy TO DISPLAY ONLY THE PROGRESS BAR
' -------------------------------------
for x = 1 to 20
Update(x & "/20")
wscript.sleep(200)
next
' "x/yy your message here" TO DISPLAY INFO AND PROGRESS
' -----------------------------------------------------
for x = 0 to 20
Update(x & "/20 Downloading files...")
wscript.sleep(200)
next
for x = 0 to 20
Update(x & "/20 Installing files and updating the registry...")
wscript.sleep(200)
next
Update("0/0 Done!")
wscript.sleep(2000)
Update("0/0 Formatting your PC...")
wscript.sleep(2000)
Update("0/0 Don't worry - Only kidding!")
wscript.sleep(2000)
'A SINGLE - OR -/0 CLEARS THE SCREEN
'-----------------------------------
Update("-/0")
wscript.sleep(500)
'KILL THE SPLASH APP BY FEEDING IT A BLANK FILE (THE PS1 APP WILL DELETE THE PROGRESS FILE)
'------------------------------------------------------------------------------------------
Update("")
'***************************************************************************
'DELETE THE SPLASH APP FROM THE TEMP DIRECTORY
if fso.FileExists(PS1file_) then
'Set aFile = fso.GetFile(PS1file_)
'aFile.Delete
end if
wscript.quit
'*****************************************************
Sub Update(text_)
Set fhta = fso.OpenTextFile(PROGESSfile_,2,True)
fhta.WriteLine text_
fhta.close
End Sub
'*****************************************************
Sub CreatePS1file
tempfolder = fso.GetSpecialFolder(2).ShortPath & "\"
PS1filename = Split(fso.GetTempName,".")(0)
PS1file_ = tempfolder & PS1filename & ".ps1"
PROGESSfile_ = tempfolder & PS1filename & ".tmp"
'FILL THE VARIABLE WITH THE BASE64 CODE AT THE BOTTOM OF THIS SCRIPT
Call FillBase64file_
'GET THE COMPRESSED FILE FROM THE BASE64 TEXT
base64_ = Base64file_
tempfile = fso.GetSpecialFolder(2).ShortPath & "\" & fso.GetTempName
bytes_ = decodeBase64(base64_)
writeBytes tempfile, bytes_
'DECOMPRESS THE FILE
wsh.run ("cmd /c expand """ & tempfile & """ """ & PS1file_ & """" ),0,True
if fso.FileExists(tempfile) then
Set aFile = fso.GetFile(tempfile)
aFile.Delete
end if
Do while not FSO.FileExists(PS1file_)
WScript.Sleep 100
Loop
End Sub
'*****************************************************
private function decodeBase64(base64)
dim DM, EL
Set DM = CreateObject("Microsoft.XMLDOM")
Set EL = DM.createElement("tmp")
EL.DataType = "bin.base64"
EL.Text = base64
decodeBase64 = EL.NodeTypedValue
end function
'*****************************************************
private Sub writeBytes(file, bytes)
Dim binaryStream
Set binaryStream = CreateObject("ADODB.Stream")
binaryStream.Type = 1
binaryStream.Open
binaryStream.Write bytes
binaryStream.SaveToFile file, 1
end Sub
'*****************************************************
Sub FillBase64file_
'CONTAINS THE POWERSHELL + C# SCRIPT, COMPRESSED AND
'BASE64 ENCODED BY DROPPING THE filename.ps1 FILE INTO Bin2Txt.vbs
'(CREATES filename.ps1.TXT)
Base64file_ = "TVNDRgAAAAAqCQAAAAAAACwAAAAAAAAAAwEBAAEAAAAAAAAASQAAAAEAAQDUGwAAAAAAAAAANFKgbCAAcmFkQ0RGNTcucHMxAG/VbG7ZCNQbQ0vNWXtv4sYW/5uV9jtMo6vGbh3jbFvdqpRqjTFgFWxkO4tyV6vI4AHca2w0NiHZbb77PfPwM4RuVe1t0W6YGZ/XnHPmd84YPQyv/Mc9RuzvEK+jJMqjNEFvL1+/ev3qkEXJBnmPWY53veZUHZLgCNP2suW0V/wtwUF4gnQRJWF6zNRRSnZZ+6F7SPJoh1UryTFJ9x4m99EKU7LXrzr7wzKOVijLgxy+VnGQZWhO0g3BWfb6FRKfT0DZIo2SHO0Jvo/SQ3aMwnx7h/pI650n3AvJg4DcOut1hvOXuAZpGuMgKTmzbXqcV9yULScHzDfR4r1PoxDNUvB/SqQsJ9QX6yjGSbDDdzKlZ/vpHLewKFExbFGsdnLyKEYd7kdpBHReDr7foXUGmhN8RNWa9LYUrrDlWRpi1dnjhE/1FXg7U10IHV/wtgHBbL4gUY5lWWj71Ol2VVWtafsF8QGlxQR5DlqYaOjYlz6aOsavyJ+YaGRNTSGgsLfBlNUn3Pb6c2mdlQYUHoCPcFuUrFPq605dCjN9GiVYknt1horAiNOMPy2fR2uJCVOnONnk25/7Wqm1ppY5nzlJHeIY57jmXLn3tAry1fbTE+p2dRuZs7l/y7aPFtZ0ikx7yBzimZ5nOTb1luXzRwPwmjk1fXNYafJwEs4gMMEG+3A80kMuTRb28G7gOvrQ0D1fQYvZnWf6vmWPjYluj00FwRma50T9DxwkBSWHOFaQN/OdO33guL41mtzYYwVda1qDsualjjiTZnIfkTTZ4SRXzYcol65rRE/UbXXH8TCoPol2kqx6hyWPjqQp1zLq9y+uLmTqEuSBpeCNK+S46KqrIWNq6q7HnWK4pmmf8vjf44dul4OZ6sUY76UfNK3pADHCcYZPGr0HpNryjDrFWAye2F8+EWssh/hQHDjwljF1PBNZo/JEIctrpczf4Kc/TJanIk8azrwuncm2/PQiRgov1s76zBvXERJOY4GM7LtA5fNoXIBHgfZUKFBcXPTqT0OcpLsoCQCky6eF0k9t3gK2aNZfbi4VKCrqPCAAMoXVKmwGXHOJLuX32odi1mUzWe6hJ8TB44RV6KmuuWXXX1B8zRUXoCWUwHmuq4Dje4F+/72hVmBkHzDylKvXAZyKXiXuGclX/Rfrpoz+n3mMXjzmL9nXf7bhRloUTgcvVP4v8bBcspIQPzhrGhTl1KIsf3tdPeDevjpJeHVdz52a+nre8BbnVGvzvVaLE2ppRGURFMh2rj2ikCnwyZrpY1rQANJ1KHbIsqHKDf2Jglxz6OqLGuBD5Rs5LhBb3nyq30JE+cMJhM10uaRCOiAhfTbXbwAKXXNqme9MXjxGU92bIHM0Mg2fU8NuThn787lO75+SekXUzjelJ1aLUHa76Na5QQb0IIZp++Be6iThYgUNbnxoPC49NKOeXzjur0gXrYnvzK+m5sgviAtxUGym0LUAne2wIFEGWAQXDKHFgQI1Nm3T1adIn5qu7wk+mncP1FhvRTBO1Dk0CAF5FLNFSv4Lp0IHJ8AFATr0Xo3t8bPYJjjabPNq30Ooh+7Msk00cRY06fjWF5Y9hDlk1c10CCnHqO8Dgj5CKASGDqJ8F0BtgliJOIxJsN9GqwxtqC3FTB2RdGftIEWkj0UtpFeQTmeUgt38pLOh6MNhKKGLBV7Si1F2AfK/R3JPFH0v+ohHgomOC0Cny0X32ni6uVNnOMgOBAvQr+OyUlMvmKkvl7s9O390G4BBuSxVIrnn5W/faM3i+HwHOomCmJr/o8KWvPwRumArD2jVlusoeN7gAmSaxooqdJ714qLFVMM3IfbzNsoR4qvnxedTw1kNmQxORcsHdOK+UKn8pV/xyn8gpkTckqzff6OhGltfowgBgAoXKsee3sJRe8eT2RmNAIHo0AYUnDmwbPk1R4CIiWmNJ34T3wth3sLyjQka6PR65gDEg159RMGWwYEQO9ct26/jNJCybp2tAdz6AuUligT6EP4LYAZCQPkbw3yGzPLzXdcAWdzRv/66vQLNgoa631iqiWzHR56vu/7N/JvuP61TKF8ylLurXE8roc89YtkjB7zvooHlz/R5CUWD2byJRKUYpRbSZ9B0GplAmKDcwF0XB0Qy0jilF+NQrHviGJFdkKOQBEcxrDeUfKmAoYpI5V+jONjQtw11YramDiOCV/Tl0jtMoJkPYi6BYcq6BSxncaUBK2jD3kS1YYQKVJjRaRyFA3KAGwPf7WJL314oPyrXZWkVjdJTVTF4oWNHSOA4jzvaLndgJ3hSHeN8suRBqcG9IMvCFY0BzoeG1L4jNeUxQgNyKMdGutvDNWcZY+ACCTVqD8fgO2f5G/yVgEcBO4T1kBiDOKf0CtLYP2odwzU+5OVQoaoKCs81DGd+K59pxxstXiNX564zdmndb+Xri1nVeRbdRt2rB9jFm0MckIKxEdv6FehkfJsvJlVuxi2O4/QoQ7SVf1evdlohhs/Lge2ccT+PTjsGJ7qwPxmVWsMHEGNBO3UzL9Xxd0yQI9tGjriwHGS4mXFKM484a7ERvgmujR8BgvMDSXrVDZyzvR/GsbXbpwRid8gw+e6NGsb0eHo4nwZZbhKSEnGdlj8UXHsS3UNaF5d3/JBjkggAPQXTxZFYJKHCXsDOsk0BuOgI99dgV1R6FIvpgdKtDwxhxOwg5JWs8T48ujg7xKz9OWkbxfA0iR8LlmbFELnLn0nawxo+z0Wt0iTLmd3t+kKvQw/XwRmOdrFhHJqmvRHxeX/+rbh6Oj40FO1XKM0o1BEKbY9JKP95hZsw+mx9J4CuAsIvrLtxiCutZZpsQVi6/O1LWUHDLHCiUj7Mcp7qD+XosRwd+de2sjBceWQlGMrRYzkC8zh41H7EEKAiEsowIKe0L7jDEpv+Ulg/L4epvjbosSSuO+xLhXOZpjFqwGmhk09ZIBiEXr5FV9Mg2RwA6pBBf0bZoysXrzHByQqHepbhHSjAGcq4iSEvYEoxP4rfydb0dzIq8X1RqD/89FPxi9G/ArLJ6FvD3v8A"
End Sub
'*****************************************************
The messages are displayed at the top left of the screen. You can centre them, but it's a bit of a faff and I find that users prefer the top-left display, especially for single-line status messages.
The Splash.vbs "Update" sub writes to a text file that the Powershell+C# reads from every 100ms. If the file is blank the Powershell+C# deletes the text file and exits. If the text file is deleted the Powershell+C# exits. The Splash.vbs script then deletes the .ps1 file in the temp directory.
The text file options are:
Prompt and progress bar:
15/20 Your message...
Prompt only in a single line:
0/0 Your message...
Progress bar only in a single line:
5/30
To refresh the screen to delete the splash message, just make the first (or only) character in the file a minus ("-") sign.
To end the .ps1 application just empty the file. Obviously, you could keep it running if you wanted other VBS, powershell or batch files to display messages.
Run the Splash.vbs and all will become apparent.
This technique can be used to encapsulate other C# apps into VBS scripts, which can be directly placed on web pages. End users can then copy and paste them into their own VBS scripts, which many anti-virus software packages often ignore.
Bin2Txt.vbs can compress any binary file (.exe,.png,.mp4 etc.) so your VBS scripts can also recreate these and use them on-the-fly, assuming the anti-virus packages don't delete them first.
NOTE:
For those mistrusting people out there, I commented out the run command in the Splash.vbs file:'wsh.Run ( "powershell -NoLogo -Command ""& '" & PS1file_ & "' '" & PROGESSfile_ & "'"" "),0,false
...along with the delete routine:
'DELETE THE SPLASH APP FROM THE TEMP DIRECTORY
if fso.FileExists(PS1file_) then
'Set aFile = fso.GetFile(PS1file_)
'aFile.Delete
end if
So, run the Splash.vbs file, view the .ps1 file created in the temp directory and check that it matches the Powershell+C# script above. If you're happy, uncomment the "wsh.Run" and "aFile.Delete" commands and re-run it.
Upvotes: 1
Cherian M Paul
Reputation: 656
I found a better way to display progress while running a long script in VbScript.
I found some code in this url took it and modified it to make it look better. The problem with the other code is we can't change the size of the progress bar. I fixed it in my code. Just change m_ProgressBar.width and height. Also change margin in the html body. That's it.
Class ProgressBar
Private m_PercentComplete
Private m_CurrentStep
Private m_ProgressBar
Private m_Title
Private m_Text
Private m_Top
Private m_Left
'Initialize defaults
Private Sub Class_Initialize()
m_PercentComplete = 1
m_CurrentStep = 0
m_Title = "Progress"
m_Text = ""
m_Top = 100
m_Left = 150
End Sub
Public Function SetTitle(pTitle)
m_Title = pTitle
if IsObject(m_ProgressBar) then
m_ProgressBar.Document.title = m_PercentComplete & "% Complete : " & m_Title
m_ProgressBar.Document.GetElementById("pc").InnerHtml = m_PercentComplete & "% Complete : " & m_Title
end if
End Function
Public Function SetText(pText)
m_Text = pText
if IsObject(m_ProgressBar) then m_ProgressBar.Document.GetElementById("text").InnerHtml = m_Text
End Function
Public Function SetTop(pTop)
m_Top = pTop
End Function
Public Function SetLeft(pLeft)
m_Left = pLeft
End Function
Public Function GetTop()
GetTop = m_ProgressBar.top
End Function
Public Function GetLeft()
GetLeft = m_ProgressBar.left
End Function
Public Function Update(percentComplete)
If percentComplete > 100 Then
m_PercentComplete = 100
elseif percentComplete < 1 then
m_PercentComplete = 1
else
m_PercentComplete = percentComplete
end if
UpdateProgressBar()
End Function
Public Function Show()
Set m_ProgressBar = CreateObject("InternetExplorer.Application")
'in code, the colon acts as a line feed
m_ProgressBar.navigate2 "about:blank" : m_ProgressBar.width = 800 : m_ProgressBar.height = 380 : m_ProgressBar.toolbar = false : m_ProgressBar.menubar = false : m_ProgressBar.statusbar = false : m_ProgressBar.visible = True : m_ProgressBar.Resizable = False : m_ProgressBar.top = m_Top : m_ProgressBar.left = m_Left
m_ProgressBar.document.write "<body Scroll=no style='margin:100px;'><div style='text-align:center;padding:15px;'><span name='pc' id='pc'>0% Complete</span></div>"
m_ProgressBar.document.write "<div id='statusbar' name='statusbar' style='border:1px solid blue;line-height:22px;height:30px;color:blue;'>" _
& "<table width='100%' height='100%'><tr><td id='progress' style='width:1%' bgcolor='#0000FF'></td><td></td></tr></table></div>"
m_ProgressBar.document.write "<div style='text-align:center;padding:15px;'><span id='text' name='text'></span></div>"
End Function
Public Function Close()
m_ProgressBar.quit
End Function
Private Function UpdateProgressBar()
if m_CurrentStep <> m_PercentComplete then
If m_PercentComplete = 100 Then
m_ProgressBar.Document.GetElementById("statusbar").InnerHtml = "<table width='100%' height='100%'><tr><td bgcolor='#0000FF'></td></tr></table>"
else
m_ProgressBar.Document.GetElementById("progress").style.width = m_PercentComplete & "%"
end if
m_ProgressBar.Document.title = m_PercentComplete & "% Complete : " & m_Title
m_ProgressBar.Document.GetElementById("pc").InnerHtml = m_PercentComplete & "% Complete : " & m_Title
m_ProgressBar.Document.GetElementById("text").InnerHtml = m_Text
m_CurrentStep = m_PercentComplete
end if
End Function
End Class
Then you add the below code to display the progress bar and update the current status of progress.
'Declare progressbar and percentage complete
Dim pb
Dim percentComplete
'Setup the initial progress bar
Set pb = New ProgressBar
percentComplete = 0
pb.SetTitle("Step 1 of 5")
pb.SetText("Copying bin/Debug Folder")
pb.SetTop(150) ' These are optional
pb.SetLeft(300) ' These are optional
pb.Show()
'Loop to update the percent complete of the progress bar
'Just add the pb.Update in your code to update the bar
'Text can be updated as well by pb.SetText
Do While percentComplete <= 100
wscript.sleep 500
pb.Update(percentComplete)
percentComplete = percentComplete + 10
Loop
wscript.sleep 2000
pb.Close()
'This shows how you can use the code for multiple steps
Set pb = New ProgressBar
percentComplete = 0
pb.SetTitle("Step 2 of 5")
pb.SetText("Copying bin/Release Folder")
pb.Show()
pb.Update(percentComplete)
Do While percentComplete <= 100
wscript.sleep 500
pb.Update(percentComplete)
percentComplete = percentComplete + 10
Loop
msgbox "Completed", vbSystemModal
pb.Close()
wscript.quit
Upvotes: 0
Concept211
Reputation: 1076
If you're running your script in a console window (via cscript.exe) then you can display a faux progress bar directly in the window/output like this:
First declare the following functions in your VBS file:
Function printi(txt)
WScript.StdOut.Write txt
End Function
Function printr(txt)
back(Len(txt))
printi txt
End Function
Function back(n)
Dim i
For i = 1 To n
printi chr(08)
Next
End Function
Function percent(x, y, d)
percent = FormatNumber((x / y) * 100, d) & "%"
End Function
Function progress(x, y)
Dim intLen, strPer, intPer, intProg, intCont
intLen = 22
strPer = percent(x, y, 1)
intPer = FormatNumber(Replace(strPer, "%", ""), 0)
intProg = intLen * (intPer / 100)
intCont = intLen - intProg
printr String(intProg, ChrW(9608)) & String(intCont, ChrW(9618)) & " " & strPer
End Function
Function ForceConsole()
Set oWSH = CreateObject("WScript.Shell")
vbsInterpreter = "cscript.exe"
If InStr(LCase(WScript.FullName), vbsInterpreter) = 0 Then
oWSH.Run vbsInterpreter & " //NoLogo " & Chr(34) & WScript.ScriptFullName & Chr(34)
WScript.Quit
End If
End Function
Then at the top of your script use the following example:
ForceConsole()
For i = 1 To 100
progress(i, 100)
Next
Upvotes: 9
Ansgar Wiechers
Reputation: 200473
Don't use popup messages for this unless you want to annoy the heck out of your users. Wrap your code in an HTA that displays a progress indicator like the one in this page, e.g.:
<html>
<head>
<title>Sample</title>
<hta:application
applicationname="Sample"
scroll="no"
singleinstance="yes"
windowstate="normal"
>
<script language="vbscript">
Sub Window_onLoad
'your code here
End Sub
</script>
<style type="text/css">
* {
font-size: 1px;
margin: 1px;
}
div {
position: absolute;
left: 40%;
top: 50%;
}
marquee {
border: 1px solid;
height: 15px;
width: 200px;
}
marquee span {
height: 11px;
width: 8px;
background: Highlight;
float: left;
}
.handle-0 { filter: alpha(opacity=20); -moz-opacity: 0.20; }
.handle-1 { filter: alpha(opacity=40); -moz-opacity: 0.40; }
.handle-2 { filter: alpha(opacity=60); -moz-opacity: 0.6; }
.handle-3 { filter: alpha(opacity=80); -moz-opacity: 0.8; }
.handle-4 { filter: alpha(opacity=100); -moz-opacity: 1; }
</style>
</head>
<body>
<div>
<marquee direction="right" scrollamount="8" scrolldelay="100">
<span class="handle-0"></span>
<span class="handle-1"></span>
<span class="handle-2"></span>
<span class="handle-3"></span>
<span class="handle-4"></span>
</marquee>
</div>
</body>
</html>
If you want to provide some more dynamic information, you could for instance add a paragraph like this to the body:
</div>
<p id="sline" style="visibility:hidden;">Processed
<span id="rcount"></span> Records.</p>
</body>
</html>
and update it every 1000 records:
...
If numRows Mod 1000 = 0 Then
If sline.style.visibility = "hidden" Then sline.style.visibility = "visible"
rcount.innerText = numRows
End If
...
Upvotes: 4
Kul-Tigin
Reputation: 16950
In such cases I'd like to use WshShell.Popup method to provide information about the current progress.
Here an example:
Dim WshShell, i
Set WshShell = CreateObject("WScript.Shell")
For i = 1 To 500
'Do Something
If i Mod 100 = 0 Then 'inform for every 100 process
WshShell.Popup i & " items processed", 1, "Progress" ' show message box for a second and close
End If
Next
Upvotes: 4
Related Questions
- Download progress with VBS and batch
- Wait for program to complete
- How do I let cmd know VB script has finished?
- Display Progress Bar at the Time of Processing
- vb.net show progress bar while program take some time to complete
- Prompt Message Box when progress bar value hits 0
- VBScript - How to know when complete?
- Progress dialog box in VB.NET?
- Showing running script progress in winform progressbar
- How to work with progress bar in VB.Net win form application