Dynamic Activity Window動態活動窗口vbs

2020-07-26 11:55:08
字體：大中小
來源：轉載
供稿：網友
復制代碼代碼如下:
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