Dynamic Activity Window动态活动窗口vbs

Option Explicit
Dim oBar
Set oBar = New ProgressBar
oBar.StartBar "This is a test."
WScript.Sleep (3000)
oBar.SetLine "So is this."
WScript.Sleep (3000)
oBar.CloseBar
Class ProgressBar
Dim oBarCat, sProgressBarHTAFile, sProgressBarRunFile, sProgressBarSleepFile, sInitialTempBuild
Public Sub StartBar(sMessageToDisplay)
Dim sInitialTemp, i
ExecuteGlobal "Dim oShell, oFSO, oEnv"
Set oShell = CreateObject("Wscript.Shell")
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oEnv = oShell.Environment("Process")
For i = 1 To 16
sInitialTempBuild = sInitialTempBuild Chr(fRand(97,122))
Next
sInitialTemp = oFSO.GetDriveName(oEnv("TEMP")) "\" sInitialTempBuild "\" oFSO.GetFileName(fGetTempName)
sProgressBarHTAFile = Left(sInitialTemp,(Len(sInitialTemp)-4)) ".hta"
sProgressBarRunFile = Left(sProgressBarHTAFile, Len(sProgressBarHTAFile)-4) ".run"
sProgressBarSleepFile = Left(sProgressBarHTAFile, Len(sProgressBarHTAFile)-4) "sleep.vbs"
Set oBarCat = CreateObject("Scripting.Dictionary")
oBarCat.Add oBarCat.Count, "html>"
oBarCat.Add oBarCat.Count, "head>"
oBarCat.Add oBarCat.Count, "title id=" Chr(34) "title" Chr(34) ">Please Wait/title>"
oBarCat.Add oBarCat.Count, "HTA:APPLICATION "
oBarCat.Add oBarCat.Count, " ID=" Chr(34) "StatusBar" Chr(34) ""
oBarCat.Add oBarCat.Count, " APPLICATIONNAME=" Chr(34) "StatusBar" Chr(34) ""
oBarCat.Add oBarCat.Count, " SCROLL=" Chr(34) "NO" Chr(34) ""
oBarCat.Add oBarCat.Count, " SINGLEINSTANCE=" Chr(34) "YES" Chr(34) ""
oBarCat.Add oBarCat.Count, " CAPTION=" Chr(34) "NO" Chr(34) ""
oBarCat.Add oBarCat.Count, " BORDER=" Chr(34) "NO" Chr(34) ""
oBarCat.Add oBarCat.Count, " BORDERSTYLE=" Chr(34) "NORMAL" Chr(34) ""
oBarCat.Add oBarCat.Count, " SYSMENU=" Chr(34) "NO" Chr(34) ""
oBarCat.Add oBarCat.Count, " CONTEXTMENU=" Chr(34) "NO" Chr(34) ""
oBarCat.Add oBarCat.Count, " SHOWINTASKBAR=" Chr(34) "NO" Chr(34) ""
oBarCat.Add oBarCat.Count, " />"
oBarCat.Add oBarCat.Count, "SCRIPT Language=" Chr(34) "VBScript" Chr(34) ">"
oBarCat.Add oBarCat.Count, "Dim oShell, iTimer1, iTimer2, sStatusBarAsciiText, sPID, iCID, sStatusMsg"
oBarCat.Add oBarCat.Count, "Set oShell = CreateObject(" Chr(34) "Wscript.Shell" Chr(34) ")"
oBarCat.Add oBarCat.Count, "sPID = " Chr(34) "" Chr(34) ":iCID = 10"
oBarCat.Add oBarCat.Count, "Sub Window_Onload"
oBarCat.Add oBarCat.Count, " window.resizeTo 320,250"
oBarCat.Add oBarCat.Count, " CreateObject(" Chr(34) "Scripting.FileSystemObject" Chr(34) ").CreateTextFile(" Chr(34) sProgressBarRunFile Chr(34) ")"
oBarCat.Add oBarCat.Count, " CreateObject(" Chr(34) "Scripting.FileSystemObject" Chr(34) ").CreateTextFile(" Chr(34) sProgressBarSleepFile Chr(34) ")"
oBarCat.Add oBarCat.Count, " CreateObject(" Chr(34) "Scripting.FileSystemObject" Chr(34) ").OpenTextFile(" Chr(34) sProgressBarSleepFile Chr(34) ",2).WriteLine " Chr(34) "WScript.Sleep(1000)" Chr(34) ""
oBarCat.Add oBarCat.Count, " iTimer1 = window.setInterval(" Chr(34) "Do_Refresh" Chr(34) ",175)"
oBarCat.Add oBarCat.Count, " iTimer2 = window.setInterval(" Chr(34) "Do_Nothing" Chr(34) ",500)"
oBarCat.Add oBarCat.Count, "End Sub"
oBarCat.Add oBarCat.Count, "Sub Do_Nothing"
oBarCat.Add oBarCat.Count, " If CreateObject(" Chr(34) "Scripting.FileSystemObject" Chr(34) ").FileExists(" Chr(34) sProgressBarRunFile Chr(34) ") Then"
oBarCat.Add oBarCat.Count, " Dim oWMIService, cItems, oItem"
oBarCat.Add oBarCat.Count, " Set oWMIService = GetObject(" Chr(34) "winmgmts:\\.\root\CIMV2" Chr(34) ")"
oBarCat.Add oBarCat.Count, " Set cItems = oWMIService.ExecQuery(" Chr(34) "SELECT Name, ExecutablePath, CommandLine FROM Win32_Process where Name = 'mshta.exe'" Chr(34) ")"
oBarCat.Add oBarCat.Count, " For Each oItem in cItems"
oBarCat.Add oBarCat.Count, " If oItem.CommandLine = document.Location.pathname Then"
oBarCat.Add oBarCat.Count, " oShell.AppActivate oItem.Handle"
oBarCat.Add oBarCat.Count, " End If"
oBarCat.Add oBarCat.Count, " Next"
oBarCat.Add oBarCat.Count, " Else"
oBarCat.Add oBarCat.Count, " CreateObject(" Chr(34) "Scripting.FileSystemObject" Chr(34) ").DeleteFile " Chr(34) sProgressBarSleepFile Chr(34) ", True "
oBarCat.Add oBarCat.Count, " window.clearInterval(iTimer1)"
oBarCat.Add oBarCat.Count, " window.clearInterval(iTimer2)"
oBarCat.Add oBarCat.Count, " self.Close"
oBarCat.Add oBarCat.Count, " End If"
oBarCat.Add oBarCat.Count, "End Sub"
oBarCat.Add oBarCat.Count, "Sub Do_Refresh"
oBarCat.Add oBarCat.Count, " Select Case iCID"
oBarCat.Add oBarCat.Count, " Case 10"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText =" Chr(34) "ooooo" Chr(34) ":iCID = 0"
oBarCat.Add oBarCat.Count, " Case 0"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "oooon" Chr(34) ":iCID = 1"
oBarCat.Add oBarCat.Count, " Case 1"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "ooono" Chr(34) ":iCID = 2"
oBarCat.Add oBarCat.Count, " Case 2"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "oonoo" Chr(34) ":iCID = 3"
oBarCat.Add oBarCat.Count, " Case 3"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "onooo" Chr(34) ":iCID = 4"
oBarCat.Add oBarCat.Count, " Case 4"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "noooo" Chr(34) ":iCID = 5"
oBarCat.Add oBarCat.Count, " Case 5"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "onooo" Chr(34) ":iCID = 6"
oBarCat.Add oBarCat.Count, " Case 6"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "oonoo" Chr(34) ":iCID = 7"
oBarCat.Add oBarCat.Count, " Case 7"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "ooono" Chr(34) ":iCID = 8"
oBarCat.Add oBarCat.Count, " Case 8"
oBarCat.Add oBarCat.Count, " sStatusBarAsciiText = " Chr(34) "oooon" Chr(34) ":iCID = 1"
oBarCat.Add oBarCat.Count, " End Select "
oBarCat.Add oBarCat.Count, " Stats.innerHTML = sStatusBarAsciiText"
oBarCat.Add oBarCat.Count, " On Error Resume Next"
oBarCat.Add oBarCat.Count, " oShell.RegRead(" Chr(34) "HKLM\SYSTEM\ProgressBar\MSG" Chr(34) ")"
oBarCat.Add oBarCat.Count, " iRegErr = Err.Number"
oBarCat.Add oBarCat.Count, " On Error Goto 0"
oBarCat.Add oBarCat.Count, " If iRegErr = 0 then"
oBarCat.Add oBarCat.Count, " sStatusMsg = Replace(oShell.RegRead(" Chr(34) "HKLM\SYSTEM\ProgressBar\MSG" Chr(34) "), VbCrLf," Chr(34) "br>" Chr(34) ") "
oBarCat.Add oBarCat.Count, " Else"
oBarCat.Add oBarCat.Count, " sStatusMsg = " Chr(34) "" Chr(34) ""
oBarCat.Add oBarCat.Count, " End if"
oBarCat.Add oBarCat.Count, " MyMsg.innerHTML = sStatusMsg"
oBarCat.Add oBarCat.Count, " End Sub"
oBarCat.Add oBarCat.Count, "/SCRIPT>"
oBarCat.Add oBarCat.Count, "style>"
oBarCat.Add oBarCat.Count, "body,td,a {font-family:Arial;font-size:12px;text-decoration:none;color:black;}"
oBarCat.Add oBarCat.Count, "body {filter:progid:DXImageTransform.Microsoft.Gradient(GradientType=0, StartColorStr='#9999FF', EndColorStr='#FFFFFF')}"
oBarCat.Add oBarCat.Count, ".pix {width: 1px; height 1px;}"
oBarCat.Add oBarCat.Count, "/style>"
oBarCat.Add oBarCat.Count, "/head>"
oBarCat.Add oBarCat.Count, "body>"
oBarCat.Add oBarCat.Count, "center>"
oBarCat.Add oBarCat.Count, "table width=" Chr(34) "275" Chr(34) ">"
oBarCat.Add oBarCat.Count, " tr>td>"
oBarCat.Add oBarCat.Count, " fieldset>legend align=" Chr(34) "center" Chr(34) ">b> Please Be Patient /b>/legend>"
oBarCat.Add oBarCat.Count, " br>center>"
oBarCat.Add oBarCat.Count, " span id= " Chr(34) "Stats" Chr(34) " style=" Chr(34) "font-family: wingdings;font-weight: bold;font-size:20px;" Chr(34) ">/span>"
oBarCat.Add oBarCat.Count, " /center>br>br>"
oBarCat.Add oBarCat.Count, " /fieldset>"
oBarCat.Add oBarCat.Count, " /td>/tr>"
oBarCat.Add oBarCat.Count, "/table>"
oBarCat.Add oBarCat.Count, "span id= " Chr(34) "MyMsg" Chr(34) " style=" Chr(34) "font-family: Ariel;font-size:12px;" Chr(34) ">/span>"
oBarCat.Add oBarCat.Count, "/body>"
oBarCat.Add oBarCat.Count, "/html>"
subWriteFile sProgressBarHTAFile, Join(oBarCat.Items,VbCrLf)
oShell.RegWrite "HKLM\SYSTEM\ProgressBar\MSG", sMessageToDisplay, "REG_SZ"
oShell.Run sProgressBarHTAFile, 1, False
End Sub
Public Sub CloseBar()
fKillFile sProgressBarRunFile
Dim sProgressBarHTAFileKiller
subKillRegKey "HKLM\SYSTEM\ProgressBar","DELETE"
sProgressBarHTAFileKiller = oFSO.GetDriveName(oEnv("TEMP")) "\htakiller.vbs"
subWriteFile sProgressBarHTAFileKiller, "On Error Resume Next"
subWriteFile sProgressBarHTAFileKiller, "wscript.sleep(10000)"
subWriteFile sProgressBarHTAFileKiller, "Set oFSO = CreateObject(""Scripting.FileSystemObject"")"
subWriteFile sProgressBarHTAFileKiller, "oFSO.DeleteFile " Chr(34) sProgressBarHTAFile Chr(34) ", True"
subWriteFile sProgressBarHTAFileKiller, "oFSO.DeleteFolder " Chr(34) oFSO.GetDriveName(oEnv("TEMP")) "\" sInitialTempBuild Chr(34) ", True"
subWriteFile sProgressBarHTAFileKiller, "oFSO.DeleteFile " Chr(34) sProgressBarHTAFileKiller Chr(34) ", True"
oShell.Run "%comspec% /c cscript.exe " sProgressBarHTAFileKiller, 0, False
End Sub
Public Sub SetLine(sNewText)
oShell.RegWrite "HKLM\SYSTEM\ProgressBar\MSG", sNewText, "REG_SZ"
End Sub
Private Function fGetTempName()
Dim iFilenameCharacters, iHighestASCiiValue, iLowestASCiiValue
Dim iCharASCiiValue, sTmpFileName, oTempNameDic
Set oTempNameDic = CreateObject("Scripting.Dictionary")
iFilenameCharacters = 8
iHighestASCiiValue = 126
iLowestASCiiValue = 46
sTmpFileName = ""
Randomize
Do
iCharASCiiValue = Int(((iHighestASCiiValue - iLowestASCiiValue + 1) * Rnd) + iLowestASCiiValue)
Select Case True
Case iCharASCiiValue = 47
Case iCharASCiiValue > 57 And iCharASCiiValue 95
Case iCharASCiiValue = 96
Case iCharASCiiValue > 122 And iCharASCiiValue 126
Case Else
oTempNameDic.Add oTempNameDic.Count,Chr(iCharASCiiValue)
End Select
Loop While oTempNameDic.Count iFilenameCharacters
fGetTempName = oEnv("TEMP") "\" Join(oTempNameDic.Items,"") ".tmp"
oTempNameDic.RemoveAll
End Function
Private Function fKillFile(sFileToKill)
Dim iErr, sErr
Select Case True
Case InStr(sFileToKill, "*") > 0
If oFSO.FolderExists(oFSO.GetParentFolderName(sFileToKill)) Then
On Error Resume Next
oFSO.DeleteFile sFileToKill, True
iErr = Err.Number
sErr = Err.Description
On Error GoTo 0
If iErr = 53 Then iErr = 0
End If
Case oFSO.FileExists(sFileToKill)
On Error Resume Next
oFSO.DeleteFile sFileToKill, True
iErr = Err.Number
sErr = Err.Description
On Error GoTo 0
End Select
Select Case iErr
Case 0
fKillFile = 0
Case Else
fKillFile = sErr
End Select
End Function
Private Function fRand(iLowerLimit,iUpperLimit)
ExecuteGlobal "Dim bRandomized"
If bRandomized > True Then Randomize
bRandomized = True
fRand = Int((iUpperLimit - iLowerLimit + 1)*Rnd() + iLowerLimit)
End Function
Private Sub subWriteFile(sFileToWrite, sTextToWrite)
Dim oFileToWrite
subCreateFile sFileToWrite
Set oFileToWrite = oFSO.OpenTextFile(sFileToWrite,8)
oFileToWrite.WriteLine sTextToWrite
oFileToWrite.Close
End Sub
Private Sub subCreateFile(sFileToCreate)
subCreateFolder oFSO.GetParentFolderName(sFileToCreate)
If Not oFSO.FileExists(sFileToCreate) Then oFSO.CreateTextFile(sFileToCreate)
End Sub
Private Sub subCreateFolder(sFolderPathToCreate)
If Trim(sFolderPathToCreate) > "" Then
If oFSO.FolderExists(sFolderPathToCreate) Then
Exit Sub
Else
subCreateFolder(oFSO.GetParentFolderName(sFolderPathToCreate))
End If
oFSO.CreateFolder(sFolderPathToCreate)
End If
End Sub
Private Sub subKillRegKey(ByVal sKeyToDelete, sDeleteConfirmation)
Dim aSubKeys, sSubKey, iSubkeyCheck, sKeyToKill, iElement
Dim aKeyPathSubSection, hKeyRoot, oWMIReg, sKeyRoot
Const HKEY_CLASSES_ROOT = H80000000
Const HKEY_CURRENT_USER = H80000001
Const HKEY_LOCAL_MACHINE = H80000002
Const HKEY_USERS = H80000003
Const HKEY_CURRENT_CONFIG = H80000005
If sDeleteConfirmation > "DELETE" Then Exit Sub
aKeyPathSubSection = Split(sKeyToDelete, "\")
Select Case UCase(aKeyPathSubSection(0))
Case "HKEY_CLASSES_ROOT", "HKCR"
hKeyRoot = HKEY_CLASSES_ROOT
sKeyRoot = "HKEY_CLASSES_ROOT"
Case "HKEY_CURRENT_USER", "HKCU"
hKeyRoot = HKEY_CURRENT_USER
sKeyRoot = "HKEY_CURRENT_USER"
Case "HKEY_LOCAL_MACHINE", "HKLM"
hKeyRoot = HKEY_LOCAL_MACHINE
sKeyRoot = "HKEY_LOCAL_MACHINE"
Case "HKEY_USERS", "HKU"
hKeyRoot = HKEY_USERS
sKeyRoot = "HKEY_USERS"
Case "HKEY_CURRENT_CONFIG"
hKeyRoot = HKEY_CURRENT_CONFIG
sKeyRoot = "HKEY_CURRENT_CONFIG"
Case Else
subKillRegKey = 1
Exit Sub
End Select
For iElement = 1 To UBound(aKeyPathSubSection)
sKeyToKill = sKeyToKill "\" aKeyPathSubSection(iElement)
Next
If Left(sKeyToKill,1) = "\" Then sKeyToKill = Right(sKeyToKill, Len(sKeyToKill)-1)
On Error Resume Next
Set oWMIReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
iSubkeyCheck = oWMIReg.EnumKey(hKeyRoot, sKeyToKill, aSubKeys)
If iSubkeyCheck = 0 And IsArray(aSubKeys) Then
For Each sSubKey In aSubKeys
If Err.Number > 0 Then
Err.Clear
Exit Sub
End If
subKillRegKey sKeyRoot "\" sKeyToKill "\" sSubKey, "DELETE"
Next
End If
oWMIReg.DeleteKey hKeyRoot, sKeyToKill
End Sub
End Class