Question

如何在VBScript中制作假冒进度条？我想做一个假装它正在下载东西的程序。我希望通过添加一个移动进度条来实现它，如果可能的话我该怎么做？

Answer 1

以下是从Internet下载文件时可以创建HTA ProgressBar的示例：

Option Explicit
If AppPrevInstance() Then 
    MsgBox "The script is already launching" & vbCrlf &_
    CommandLineLike(WScript.ScriptName),VbExclamation,"The script is already launching"    
    WScript.Quit  
Else    
    Const Copyright = " by Hackoo 2018"
    Dim Title : Title = "Get Header Location and download file" & Copyright
    Const WHR_EnableRedirects = 6
    Dim Default_Link,Base_Link,Dynamic_Link,Flag,Question,DirectLink,Save2File
    Dim fso,ws,Temp,WaitingMsg,oExec
    Default_Link = "https://downloads.malwarebytes.com/file/mb3/"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ws = CreateObject("WScript.Shell")
    Temp = ws.ExpandEnvironmentStrings("%Temp%")
' "https://downloads.malwarebytes.com/file/mb3/" 'Tested OK ==> Malwarebytes v3.5.1
' "https://download.toolslib.net/download/file/1/1511" 'Tested OK ==> Adwcleaner v7.1.1
' "https://www.google.tn/images/branding/googlelogo/1x/googlelogo_color_272x92dp.png" Tested OK ==> a direct link example
    Base_Link = InputBox("Copy and paste your link here to get the response header",Title,Default_Link)
    If CheckDirectLink(Base_Link) = True And Instr(Base_Link,"php") = 0 Then 'Check if it is a direct link
        Save2File = GetFileNamefromDirectLink(Base_Link)
        If Save2File = "" Then
            MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
            Wscript.Quit()
        End If
        WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
        Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
        Call LaunchProgressBar() 'Launch of the Waiting Bar
        Call Download(Base_Link,Save2File)
        pause(3)
        Call CloseProgressBar()
        MsgBox "The download of the file : "& Save2File & vbCrlf &_
        "is Completed !",vbInformation,Title
        wscript.Quit()
    End If
    Call GetHeaderLocation(Base_Link)
    If Flag = True And CheckDirectLink(GetHeaderLocation(Base_Link)) = True Then 'Checking for a direct link of Malwarebytes 
        Save2File = GetFileNamefromDirectLink(GetHeaderLocation(Base_Link))
        If Save2File = "" Then
            MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
            Wscript.Quit()
        End If
        DirectLink = GetHeaderLocation(Base_Link)
'wscript.echo DirectLink & vbCrlf & Save2File
        Question = MsgBox("Did you want to download this file ?" & vbCrlf &_
        Save2File,vbQuestion+vbYesNo,Title)
        If Question = vbYes Then
            If Save2File <> "" Then
                WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
                Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
                Call LaunchProgressBar() 'Launch of the Waiting Bar
                Call Download(DirectLink,Save2File)
                Call CloseProgressBar()
                MsgBox "The download of the file : "& Save2File & vbCrlf &_
                "is Completed !",vbInformation,Title
                Wscript.Quit()
            End If  
        End If
    ElseIf Instr(Base_Link,"toolslib") <> 0 And Flag = True Then 'for Adwcleaner
        Dynamic_Link = Extract_Dynamic_Link(GetDataFromURL(Base_Link,"Get", ""))
        Save2File = GetFileName(GetHeaderLocation(Dynamic_Link))
        If Save2File = "" Then
            MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
            Wscript.Quit()
        End If
        Question = MsgBox("The Dynamic Link is = "& Dynamic_Link & vbcrlf & vbcrlf &_
        "Response of The Dynamic Link is : "& vbcrlf & GetHeaderLocation(Dynamic_Link) & vbCrlf & vbCrlf &_
        "Extracted FileName is = " & Save2File,vbYesNo+vbQuestion,Title)
        If Question = vbYes Then
            WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
            Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
            Call LaunchProgressBar() 'Launch of the Waiting Bar
            Call Download(Dynamic_Link,Save2File)
            Call CloseProgressBar()
            MsgBox "The download of the file : "& Save2File & vbCrlf &_
            "is Completed !",vbInformation,Title
        Else
            Wscript.Quit()
        End If      
    ElseIf Instr(Base_Link,"php") > 0 And Flag = False Then
        Save2File = GetFileName(GetHeaderLocation(Base_Link)) ' for site of autoitscript.fr
        If Save2File = "" Then 
            MsgBox "An unknown error has occurred ! Quitting the script !",vbCritical,Title
            Wscript.Quit()
        End If
        Question = MsgBox("Did you want to download this file ?" & vbCrlf &_
        Save2File,vbQuestion+vbYesNo,Title)
        If Question = vbYes Then
            WaitingMsg = "Please wait ... The download of : <font color=Yellow>"& DblQuote(Save2File) & "</font> is in progress ..."
            Call CreateProgressBar(Title,WaitingMsg)'Creation of Waiting Bar
            Call LaunchProgressBar() 'Launch of the Waiting Bar
            Call Download(Base_Link,Save2File)
            pause(3)
            Call CloseProgressBar()
            MsgBox "The download of the file : "& Save2File & vbCrlf &_
            "is Completed !",vbInformation,Title
        Else
            Wscript.Quit()
        End If
    End If
End If
'------------------------------------------------
Function GetHeaderLocation(URL)
    On Error Resume Next
    Dim h,GetLocation
    Set h = CreateObject("WinHttp.WinHttpRequest.5.1")
    h.Option(WHR_EnableRedirects) = False
    h.Open "HEAD", URL , False
    h.Send()
    GetLocation = h.GetResponseHeader("Location")
    If Err = 0 Then
        Flag = True
        GetHeaderLocation = GetLocation
    Else
        Flag = False
        GetHeaderLocation = h.GetResponseHeader("Content-Disposition")
    End If  
End Function
'---------------------------------------------
Function GetFileName(Data)
    Dim regEx, Match, Matches,FileName
    Set regEx = New RegExp
    regEx.Pattern = "\x27{2}(\w.*)"
    regEx.IgnoreCase = True
    regEx.Global = True
    If regEx.Test(Data) Then
        Set Matches = regEx.Execute(Data)
        For Each Match in Matches
            FileName = Match.subMatches(0)
        Next
    Else
        Set regEx = New RegExp
        regEx.Pattern = "\x22(\w.*)\x22"
        regEx.IgnoreCase = True
        regEx.Global = True
        Set Matches = regEx.Execute(Data)
        For Each Match in Matches
            FileName = Match.subMatches(0)
        Next
    End If
    GetFileName = FileName
End Function
'---------------------------------------------
Function Extract_Dynamic_Link(Data)
    Dim regEx, Match, Matches,Dynamic_Link
    Set regEx = New RegExp
    regEx.Pattern = Base_Link & "\?s=[^""]*"
    regEx.IgnoreCase = True
    regEx.Global = True
    Set Matches = regEx.Execute(Data)
    For Each Match in Matches
        Dynamic_Link = Match.Value
    Next
    Extract_Dynamic_Link = Dynamic_Link
End Function
'------------------------------------------------
Function GetDataFromURL(strURL, strMethod, strPostData)
    Dim lngTimeout
    Dim strUserAgentString
    Dim intSslErrorIgnoreFlags
    Dim blnEnableRedirects
    Dim blnEnableHttpsToHttpRedirects
    Dim strHostOverride
    Dim strLogin
    Dim strPassword
    Dim strResponseText
    Dim objWinHttp
    lngTimeout = 59000
    strUserAgentString = "http_requester/0.1"
    intSslErrorIgnoreFlags = 13056 ' 13056: ignore all err, 0: accept no err
    blnEnableRedirects = True
    blnEnableHttpsToHttpRedirects = True
    strHostOverride = ""
    strLogin = ""
    strPassword = ""
    Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    objWinHttp.SetTimeouts lngTimeout, lngTimeout, lngTimeout, lngTimeout
    objWinHttp.Open strMethod, strURL
    If strMethod = "POST" Then
        objWinHttp.setRequestHeader "Content-type", _
        "application/x-www-form-urlencoded"
    End If
    If strHostOverride <> "" Then
        objWinHttp.SetRequestHeader "Host", strHostOverride
    End If
    objWinHttp.Option(0) = strUserAgentString
    objWinHttp.Option(4) = intSslErrorIgnoreFlags
    objWinHttp.Option(6) = blnEnableRedirects
    objWinHttp.Option(12) = blnEnableHttpsToHttpRedirects
    If (strLogin <> "") And (strPassword <> "") Then
        objWinHttp.SetCredentials strLogin, strPassword, 0
    End If    
    On Error Resume Next
    objWinHttp.Send(strPostData)
    If Err.Number = 0 Then
        If objWinHttp.Status = "200" Then
            GetDataFromURL = objWinHttp.ResponseText
        Else
            GetDataFromURL = "HTTP " & objWinHttp.Status & " " & _
            objWinHttp.StatusText
        End If
    Else
        GetDataFromURL = "Error " & Err.Number & " " & Err.Source & " " & _
        Err.Description
    End If
    On Error GoTo 0
    Set objWinHttp = Nothing
End Function 
'------------------------------------------------
Sub Download(URL,Save2File)
    Dim File,Line,BS,ws
    On Error Resume Next
    Set File = CreateObject("WinHttp.WinHttpRequest.5.1")
    File.Open "GET",URL, False
    File.Send()
    If err.number <> 0 then
        Line  = Line &  vbcrlf & "Error Getting File"
        Line  = Line &  vbcrlf & "Error " & err.number & "(0x" & hex(err.number) & ") " &  vbcrlf &_
        err.description
        Line  = Line &  vbcrlf & "Source " & err.source 
        MsgBox Line,vbCritical,"Error getting file"
        Err.clear
        wscript.quit
    End If
    If File.Status = 200 Then ' File exists and it is ready to be downloaded
        Set BS = CreateObject("ADODB.Stream")
        Set ws = CreateObject("wscript.Shell")
        BS.type = 1
        BS.open
        BS.Write File.ResponseBody
        BS.SaveToFile Save2File, 2
    ElseIf File.Status = 404 Then
        MsgBox "File Not found : " & File.Status,vbCritical,"Error File Not Found"
    Else
        MsgBox "Unknown Error : " & File.Status,vbCritical,"Error getting file"
    End If
End Sub
'------------------------------------------------
Function GetFileNamefromDirectLink(URL)
    Dim ArrFile,FileName
    ArrFile = Split(URL,"/")
    FileName = ArrFile(UBound(ArrFile))
    GetFileNamefromDirectLink = FileName
End Function
'------------------------------------------------
Function CheckDirectLink(URL)
    Dim regEx
    Set regEx = New RegExp
    regEx.Pattern = "(.exe|.zip|.rar|.msi|.vbs|.bat|.hta|.txt|.log|.doc" & _
    "|.docx|.xls|.xlsx|.pdf|.mp3|.mp4|.avi|.png|.jpg|.jpeg|.bmp|.gif)"
    regEx.IgnoreCase = True
    regEx.Global = False
    If regEx.Test(URL) Then
        CheckDirectLink = True
    End If
End Function
'------------------------------------------------
'**********************************************************************************************
Sub CreateProgressBar(Title,WaitingMsg)
    Dim ws,fso,f,f2,ts,ts2,Ligne,i,fread,LireTout,NbLigneTotal,Temp,PathOutPutHTML,fhta,oExec
    Set ws = CreateObject("wscript.Shell")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Temp = WS.ExpandEnvironmentStrings("%Temp%")
    PathOutPutHTML = Temp & "\Barre.hta"
    Set fhta = fso.OpenTextFile(PathOutPutHTML,2,True)
    fhta.WriteLine "<HTML>"
    fhta.WriteLine "<HEAD>"
    fhta.WriteLine "<Title>  " & Title & "</Title>"
    fhta.WriteLine "<HTA:APPLICATION"
    fhta.WriteLine "ICON = ""magnify.exe"" "
    fhta.WriteLine "BORDER=""THIN"" "
    fhta.WriteLine "INNERBORDER=""NO"" "
    fhta.WriteLine "MAXIMIZEBUTTON=""NO"" "
    fhta.WriteLine "MINIMIZEBUTTON=""NO"" "
    fhta.WriteLine "SCROLL=""NO"" "
    fhta.WriteLine "SYSMENU=""NO"" "
    fhta.WriteLine "SELECTION=""NO"" "
    fhta.WriteLine "SINGLEINSTANCE=""YES"">"
    fhta.WriteLine "</HEAD>"
    fhta.WriteLine "<BODY text=""white""><CENTER>"
    fhta.WriteLine "<marquee DIRECTION=""LEFT"" SCROLLAMOUNT=""3"" BEHAVIOR=ALTERNATE><font face=""Comic sans MS"">" & WaitingMsg &"</font></marquee>"
    fhta.WriteLine "<img src=""data:image/gif;base64,R0lGODlhgAAPAPIAAP////INPvvI0/q1xPVLb/INPgAAAAAAACH/C05FVFNDQVBFMi4wAwEAAAAh/hpDcmVhdGVkIHdpdGggYWpheGxvYWQuaW5mbwAh+QQJCgAAACwAAAAAgAAPAAAD5wiyC/6sPRfFpPGqfKv2HTeBowiZGLORq1lJqfuW7Gud9YzLud3zQNVOGCO2jDZaEHZk+nRFJ7R5i1apSuQ0OZT+nleuNetdhrfob1kLXrvPariZLGfPuz66Hr8f8/9+gVh4YoOChYhpd4eKdgwDkJEDE5KRlJWTD5iZDpuXlZ+SoZaamKOQp5wAm56loK6isKSdprKotqqttK+7sb2zq6y8wcO6xL7HwMbLtb+3zrnNycKp1bjW0NjT0cXSzMLK3uLd5Mjf5uPo5eDa5+Hrz9vt6e/qosO/GvjJ+sj5F/sC+uMHcCCoBAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/4ixgeloM5erDHonOWBFFlJoxiiTFtqWwa/Jhx/86nKdc7vuJ6mxaABbUaUTvljBo++pxO5nFQFxMY1aW12pV+q9yYGk6NlW5bAPQuh7yl6Hg/TLeu2fssf7/19Zn9meYFpd3J1bnCMiY0RhYCSgoaIdoqDhxoFnJ0FFAOhogOgo6GlpqijqqKspw+mrw6xpLCxrrWzsZ6duL62qcCrwq3EsgC0v7rBy8PNorycysi3xrnUzNjO2sXPx8nW07TRn+Hm3tfg6OLV6+fc37vR7Nnq8Ont9/Tb9v3yvPu66Xvnr16+gvwO3gKIIdszDw65Qdz2sCFFiRYFVmQFIAEBACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9J2qd1AoM9MYeF4KaWJKWmaJXxEyulI3zWa/39Xh6/vkT3q/DC/JiBFjMSCM2hUybUwrdFa3Pqw+pdEVxU3AViKVqwz30cKzmQpZl8ZlNn9uzeLPH7eCrv2l1eXKDgXd6Gn5+goiEjYaFa4eOFopwZJh/cZCPkpGAnhoFo6QFE6WkEwOrrAOqrauvsLKttKy2sQ+wuQ67rrq7uAOoo6fEwsjAs8q1zLfOvAC+yb3B0MPHD8Sm19TS1tXL4c3jz+XR093X28ao3unnv/Hv4N/i9uT45vqr7NrZ89QFHMhPXkF69+AV9OeA4UGBDwkqnFiPYsJg7jBktMXhD165jvk+YvCoD+Q+kRwTAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJdCLnC/S+nsCFo1dq5zeRoFlJ1Du91hOq3b3qNo/5OdZPGDT1QrSZDLIcGp2o47MYheJuImmVer0lmRVlWNslYndm4Jmctba5gm9sPI+gp2v3fZuH78t4Xk0Kg3J+bH9vfYtqjWlIhZF0h3qIlpWYlJpYhp2DjI+BoXyOoqYaBamqBROrqq2urA8DtLUDE7a1uLm3s7y7ucC2wrq+wca2sbIOyrCuxLTQvQ680wDV0tnIxdS/27TND+HMsdrdx+fD39bY6+bX3um14wD09O3y0e77+ezx8OgAqutnr5w4g/3e4RPIjaG+hPwc+stV8NlBixAzSlT4bxqhx46/MF5MxUGkPA4BT15IyRDlwG0uG55MAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPECwbnu3gUKH1h2ZziNKVlJWDW9FvSuI/nkusPjrF0OaBIGfTna7GaTNTPGIvK4GUZRV1WV+ssKlE/G0hmDTqVbdPeMZWvX6XacAy6LwzAF092b9+GAVnxEcjx1emSIZop3g16Eb4J+kH+ShnuMeYeHgVyWn56hakmYm6WYnaOihaCqrh0FsbIFE7Oytba0D7m6DgO/wAMTwcDDxMIPx8i+x8bEzsHQwLy4ttWz17fJzdvP3dHfxeG/0uTjywDK1Lu52bHuvenczN704Pbi+Ob66MrlA+scBAQwcKC/c/8SIlzI71/BduysRcTGUF49i/cw5tO4jytjv3keH0oUCJHkSI8KG1Y8qLIlypMm312ASZCiNA0X8eHMqPNCTo07iyUAACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9F8mk8ap8hffaB3ZiWJKfmaJgJWHV5FqQK9uPuDr6yPeTniAIzBV/utktVmPCOE8GUTc9Ia0AYXWXPXaTuOhr4yRDzVIjVY3VsrnuK7ynbJ7rYlp+6/u2vXF+c2tyHnhoY4eKYYJ9gY+AkYSNAotllneMkJObf5ySIphpe3ajiHqUfENvjqCDniIFsrMFE7Sztre1D7q7Dr0TA8LDA8HEwsbHycTLw83ID8fCwLy6ubfXtNm40dLPxd3K4czjzuXQDtID1L/W1djv2vHc6d7n4PXi+eT75v3oANSxAzCwoLt28P7hC2hP4beH974ZTEjwYEWKA9VBdBixLSNHhRPlIRR5kWTGhgz1peS30l9LgBojUhzpa56GmSVr9tOgcueFni15styZAAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKsWIPiFwhia4kWWKrl5UGXFMFa/nJ0Da+r0rF9vAiQOH0DZTMeYKJ0y6O2JPApXRmxVe3VtSVSmRLzENWm7MM+65ra93dNXHgep71H0mSzdFec+b3SCgX91AnhTeXx6Y2aOhoRBkllwlICIi49liWmaapGhbKJuSZ+niqmeN6SWrYOvIAWztAUTtbS3uLYPu7wOvrq4EwPFxgPEx8XJyszHzsbQxcG9u8K117nVw9vYD8rL3+DSyOLN5s/oxtTA1t3a7dzx3vPwAODlDvjk/Orh+uDYARBI0F29WdkQ+st3b9zCfgDPRTxWUN5AgxctVqTXUDNix3QToz0cGXIaxo32UCo8+OujyJIM95F0+Y8mMov1NODMuPKdTo4hNXgMemGoS6HPEgAAIfkECQoAAAAsAAAAAIAADwAAA/8ItAv+rD0XyaTxqnyr9pcgitpIhmaZouMGYq/LwbPMTJVE34/Z9j7BJCgE+obBnAWSwzWZMaUz+nQQkUfjyhrEmqTQGnins5XH5iU3u94Crtpfe4SuV9NT8R0Nn5/8RYBedHuFVId6iDyCcX9vXY2Bjz52imeGiZmLk259nHKfjkSVmpeWanhhm56skIyABbGyBROzsrW2tA+5ug68uLbAsxMDxcYDxMfFycrMx87Gv7u5wrfTwdfD2da+1A/Ky9/g0OEO4MjiytLd2Oza7twA6/Le8LHk6Obj6c/8xvjzAtaj147gO4Px5p3Dx9BfOQDnBBaUeJBiwoELHeaDuE8uXzONFu9tE2mvF0KSJ00q7Mjxo8d+L/9pRKihILyaB29esEnzgkt/Gn7GDPosAQAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKv2HTcJJKmV5oUKJ7qBGPyKMzNVUkzjFoSPK9YjKHQQgSve7eeTKZs7ps4GpRqDSNcQu01Kazlwbxp+ksfipezY1V5X2ZI5XS1/5/j7l/12A/h/QXlOeoSGUYdWgXBtJXEpfXKFiJSKg5V2a1yRkIt+RJeWk6KJmZhogKmbniUFrq8FE7CvsrOxD7a3Drm1s72wv7QPA8TFAxPGxcjJx8PMvLi2wa7TugDQu9LRvtvAzsnL4N/G4cbY19rZ3Ore7MLu1N3v6OsAzM0O9+XK48Xn/+notRM4D2C9c/r6Edu3UOEAgwMhFgwoMR48awnzMWOIzyfeM4ogD4aMOHJivYwexWlUmZJcPXcaXhKMORDmBZkyWa5suE8DuAQAIfkECQoAAAAsAAAAAIAADwAAA/8ItAv+rD0XyaTxqnyr9h03gZNgmtqJXqqwka8YM2NlQXYN2ze254/WyiF0BYU8nSyJ+zmXQB8UViwJrS2mlNacerlbSbg3E5fJ1WMLq9KeleB3N+6uR+XEq1rFPtmfdHd/X2aDcWl5a3t+go2AhY6EZIZmiACWRZSTkYGPm55wlXqJfIsmBaipBROqqaytqw+wsQ6zr623qrmusrATA8DBA7/CwMTFtr24yrrMvLW+zqi709K0AMkOxcYP28Pd29nY0dDL5c3nz+Pm6+jt6uLex8LzweL35O/V6fv61/js4m2rx01buHwA3SWEh7BhwHzywBUjOGBhP4v/HCrUyJAbXUSDEyXSY5dOA8l3Jt2VvHCypUoAIetpmJgAACH5BAkKAAAALAAAAACAAA8AAAP/CLQL/qw9F8mk8ap8q/YdN4Gj+AgoqqVqJWHkFrsW5Jbzbee8yaaTH4qGMxF3Rh0s2WMUnUioQygICo9LqYzJ1WK3XiX4Na5Nhdbfdy1mN8nuLlxMTbPi4be5/Jzr+3tfdSdXbYZ/UX5ygYeLdkCEao15jomMiFmKlFqDZz8FoKEFE6KhpKWjD6ipDqunpa+isaaqqLOgEwO6uwO5vLqutbDCssS0rbbGuMqsAMHIw9DFDr+6vr/PzsnSx9rR3tPg3dnk2+LL1NXXvOXf7eHv4+bx6OfN1b0P+PTN/Lf98wK6ExgO37pd/pj9W6iwIbd6CdP9OmjtGzcNFsVhDHfxDELGjxw1Xpg4kheABAAh+QQJCgAAACwAAAAAgAAPAAAD/wi0C/6sPRfJpPGqfKv2HTeBowiZjqCqG9malYS5sXXScYnvcP6swJqux2MMjTeiEjlbyl5MAHAlTEarzasv+8RCu9uvjTuWTgXedFhdBLfLbGf5jF7b30e3PA+/739ncVp4VnqDf2R8ioBTgoaPfYSJhZGIYhN0BZqbBROcm56fnQ+iow6loZ+pnKugpKKtmrGmAAO2twOor6q7rL2up7C/ssO0usG8yL7KwLW4tscA0dPCzMTWxtXS2tTJ297P0Nzj3t3L3+fmzerX6M3hueTp8uv07ezZ5fa08Piz/8UAYhPo7t6+CfDcafDGbOG5hhcYKoz4cGIrh80cPAOQAAAh+QQJCgAAACwAAAAAgAAPAAAD5wi0C/6sPRfJpPGqfKv2HTeBowiZGLORq1lJqfuW7Gud9YzLud3zQNVOGCO2jDZaEHZk+nRFJ7R5i1apSuQ0OZT+nleuNetdhrfob1kLXrvPariZLGfPuz66Hr8f8/9+gVh4YoOChYhpd4eKdgwFkJEFE5KRlJWTD5iZDpuXlZ+SoZaamKOQp5wAm56loK6isKSdprKotqqttK+7sb2zq6y8wcO6xL7HwMbLtb+3zrnNycKp1bjW0NjT0cXSzMLK3uLd5Mjf5uPo5eDa5+Hrz9vt6e/qosO/GvjJ+sj5F/sC+uMHcCCoBAA7AAAAAAAAAAAA"" />"
    fhta.WriteLine "</CENTER></BODY></HTML>"
    fhta.WriteLine "<SCRIPT LANGUAGE=""VBScript""> "
    fhta.WriteLine "Set ws = CreateObject(""wscript.Shell"")"
    fhta.WriteLine "Temp = WS.ExpandEnvironmentStrings(""%Temp%"")"
    fhta.WriteLine "Sub window_onload()"
    fhta.WriteLine "    CenterWindow 570,100"
    fhta.WriteLine "    Self.document.bgColor = ""DarkOrange"" "
    fhta.WriteLine " End Sub"
    fhta.WriteLine " Sub CenterWindow(x,y)"
    fhta.WriteLine "    Dim iLeft,itop"
    fhta.WriteLine "    window.resizeTo x,y"
    fhta.WriteLine "    iLeft = window.screen.availWidth/2 - x/2"
    fhta.WriteLine "    itop = window.screen.availHeight/2 - y/2"
    fhta.WriteLine "    window.moveTo ileft,itop"
    fhta.WriteLine "End Sub"
    fhta.WriteLine "</script>"
    fhta.close
End Sub
'**********************************************************************************************
Sub LaunchProgressBar()
    Set oExec = Ws.Exec("mshta.exe " & Temp & "\Barre.hta")
End Sub
'**********************************************************************************************
Sub CloseProgressBar()
    oExec.Terminate
End Sub
'**********************************************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
Sub Pause(Secs)    
    Wscript.Sleep(Secs * 1000)    
End Sub   
'**********************************************************************************************
Function AppPrevInstance()
    With GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")  
        With .ExecQuery("SELECT * FROM Win32_Process WHERE CommandLine LIKE " & CommandLineLike(WScript.ScriptFullName) & _
            " AND CommandLine LIKE '%WScript%' OR CommandLine LIKE '%cscript%'")
            AppPrevInstance = (.Count > 1)
        End With
    End With
End Function    
'*********************************************************************************************
Function CommandLineLike(ProcessPath)
    ProcessPath = Replace(ProcessPath, "\", "\\")
    CommandLineLike = "'%" & ProcessPath & "%'" 
End Function
'*********************************************************************************************

Answer 2

您可以使用此代码：

    set objShell = CreateObject("Wscript.shell")
sub start() 
        do while valeur < 101
            valeur = valeur + 1
            refresh 
            wait 1
        loop 
        msgbox "Loading completed!"
end sub
Sub wait (Timesec)
    objShell.Run "Timeout /T " & Timesec & " /nobreak" ,0 ,true
End Sub
sub refresh()
    document.getelementbyid("chargement").style.width = valeur&"%"
end sub

此代码使用CSS：

#barreComp
{
width:300px;
height:30px;
border: 2px solid #00cc00;  
}


#chargement
{
    width:1%;
    height:100%;
    background-color:#00cc00;
}

充电（它意味着加载）是barreComp（完成栏）内的div。当充电宽度为50％时，显示半填充矩形。你明白我的意思吗？

我如何在VBscript中制作一个虚假的进度条

2 个答案: