Search code examples
vbscriptwinhttpwinhttprequest

How to get the direct link from url that have a session ID by vbscript?

I'm trying to get the direct link from url, so i use this function to provide me the header location and for this example it works fine :

Option Explicit
Const Title = "Get Header Location"
Const WHR_EnableRedirects = 6
Dim URL,Result 
URL = "https://downloads.malwarebytes.com/file/mb3/"
Result = InputBox("Copy and Paste your link here to get the response header",Title,URL)
MsgBox GetHeaderLocation(Result),vbInformation,Title
'-------------------------------------------------------------------------------------
Function GetHeaderLocation(URL)
On Error Resume Next
Dim h,GetLocation
Set h = CreateObject("WinHttp.WinHttpRequest.5.1")
    h.Option(WHR_EnableRedirects) = False 'disable redirects
    h.Open "HEAD", URL , False
    h.Send()
GetLocation = h.GetResponseHeader("Location") 'an error occurs if not exist
If Err = 0 Then
    GetHeaderLocation = GetLocation
Else
    GetHeaderLocation = Err.Description
End If  
End Function
'-------------------------------------------------------------------------------------

but when i try with this url

https://download.toolslib.net/download/file/1/1388?s=EeATC00Djuzo7gfQUxBBdtqcm3VUFamy

it give me this message :

The requested header was not found

So my question is How to get the direct link from this url ?

What i mean by direct url is how to get with .exe in the end.

I know if i paste into browser it works and let me download as adwcleaner_7.0.8.0.exe but how can manage that with vbscript if i want to download it by the script itself.

So i need a direct link !

For example in my first URL = "https://downloads.malwarebytes.com/file/mb3/"

I got as header location like that in direct link : DirectLink = https://data-cdn.mbamupdates.com/web/mb3-setup-consumer/mb3-setup-consumer-3.4.4.2398-1.0.322-1.0.4420.exe

Solution

  • I got an answer here thanks to the member Jay that put me in the right direction ! Download_File_From_Dynamic_Link.vbs

    Option Explicit
Dim Title,Base_Link,Dynamic_Link,Save2File
Title = "Download a file with a dynamic link by Hackoo 2018"
Base_Link = "https://download.toolslib.net/download/file/1/1388"
Dynamic_Link = Extract_Dynamic_Link(GetDataFromURL(base_link,"Get", ""))

MsgBox "The Dynamic Link is = "& Dynamic_Link & vbcrlf & vbcrlf &_
"Response of The Dynamic Link is : "& vbcrlf & GetHeaderLocation(Dynamic_Link) & vbCrlf & vbCrlf &_
"Extracted FileName is = " & GetFileName(GetHeaderLocation(Dynamic_Link)),vbInformation,Title

Save2File = GetFileName(GetHeaderLocation(Dynamic_Link))
Call Download(Dynamic_Link,Save2File)

MsgBox "The download of the file : "& Save2File & vbCrlf &_
"is Completed !",vbInformation,Title
'***********************************************************************************************
Function GetHeaderLocation(URL)
Const WHR_EnableRedirects = 6
Dim h,GetLocation
On Error Resume Next
Set h = CreateObject("WinHttp.WinHttpRequest.5.1")
    h.Option(WHR_EnableRedirects) = False 'disable redirects
    h.Open "HEAD", URL , False
    h.Send()
GetLocation = h.GetResponseHeader("Content-Disposition") 'an error occurs if not exist
If Err = 0 Then
    GetHeaderLocation = GetLocation
Else
    GetHeaderLocation = Err.Description
End If  
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 GetFileName(Data)
Dim regEx, Match, Matches,FileName
    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
    GetFileName = FileName
End Function
'***********************************************************************************************

    New Version : Multi-Downloader.vbs to download from a direct or dynamic link with a progress bar in HTA.

    enter image description here enter image description here enter image description here enter image description here

    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://download.toolslib.net/download/file/1/1388"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ws = CreateObject("WScript.Shell")
    Temp = ws.ExpandEnvironmentStrings("%Temp%")
' "https://downloads.malwarebytes.com/file/mb3/" 'Tested OK ==> Malwarebytes v3.4.4
' "https://download.toolslib.net/download/file/1/1388" 'Tested OK ==> Adwcleaner v7.0.8.0
' "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
'*********************************************************************************************