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, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, "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, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, " "
oBarCat.Add oBarCat.Count, "

" oBarCat.Add oBarCat.Count, " Please Be Patient " oBarCat.Add oBarCat.Count, " " oBarCat.Add oBarCat.Count, " " oBarCat.Add oBarCat.Count, " " oBarCat.Add oBarCat.Count, " " oBarCat.Add oBarCat.Count, "

"
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, ""
oBarCat.Add oBarCat.Count, ""
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