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))

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:.rootCIMV2" & 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) & "HKLMSYSTEMProgressBarMSG" & 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) & "HKLMSYSTEMProgressBarMSG" & 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) & "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) & "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 "HKLMSYSTEMProgressBarMSG", sMessageToDisplay, "REG_SZ"

oShell.Run sProgressBarHTAFile, 1, False

End Sub

Public Sub CloseBar()

fKillFile sProgressBarRunFile

Dim sProgressBarHTAFileKiller

subKillRegKey "HKLMSYSTEMProgressBar","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 "HKLMSYSTEMProgressBarMSG", 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

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)

If Left(sKeyToKill,1) = "" Then sKeyToKill = Right(sKeyToKill, Len(sKeyToKill)-1)

On Error Resume Next

Set oWMIReg = GetObject("winmgmts:{impersonationLevel=impersonate}!.rootdefault: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"

End If

oWMIReg.DeleteKey hKeyRoot, sKeyToKill

End Sub

End Class