Comment télécharger une vidéo de youtube ?

:salut: Je suis entrain de me casser la tête :arf: pour extraire et télécharger une vidéo de youtube par un script VBS !
Bon, j'ai pu extraire le lien, mais le problème que lors du téléchargement, par powershell de ce dernier, je reçois toujours une réponse du serveur "403 Interdit"
Voici le code en question : YouTube_Downloader.vbs

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
Option Explicit
Dim Title,Converter,Youtube_URL,SourceCode,Videos,Video,ws,Download_Command,FileName,DEST,Temp
Title = "Youtube Downloader by Hackoo 2018"
Youtube_URL = InputBox("Veuillez saisir le lien de Youtube pour la conversion en lien direct et le télécharger" & vbcrlf & vbcrlf &_
"Please enter Youtube link for conversion to direct link and download it",Title,"https://www.youtube.com/watch?v=IJHPpTYtIqk")
If Youtube_URL = "" Then Wscript.Quit(1)
Converter="https://www.tubeoffline.to/downloadFrom.php?host=OnLine&video="&Youtube_URL
SourceCode = GetSourceCode(Converter)
Set ws = CreateObject("WScript.Shell")
Temp = ws.ExpandEnvironmentStrings("%Temp%")
Videos = Extracting_Videos(SourceCode)
FileName = "Balti.mp4"
DEST = Temp & "\YouTubeDownloader"
Call SmartCreateFolder(DEST)
For Each Video in Videos
    Video = URLDecode(URLDecode(Video))
    wscript.echo Video
    Download_Command = "Title "& Title & "& color 0A & echo; & echo; & echo    Please be patient Downloading "& DblQuote(FileName) &_
    "... & Powershell.exe -command ""(New-Object System.Net.WebClient).DownloadFile("& SimpleQuote(Video) & "," & SimpleQuote(DEST + "\" + FileName)&")"""
    Call Executer(Download_Command,1)
Next
'***********************************************************************
Function Executer(StrCmd,Console)
    Dim ws,MyCmd,Resultat
    Set ws = CreateObject("wscript.Shell")
'La valeur 0 pour cacher la console MS-DOS
    If Console = 0 Then
        MyCmd = "CMD /C " & StrCmd & ""
        Resultat = ws.run(MyCmd,Console,True)
        If Resultat = 0 Then
        Else
'MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
'La valeur 1 pour montrer la console MS-DOS
    If Console = 1 Then
        MyCmd = "CMD /K " & StrCmd & " "
        Resultat = ws.run(MyCmd,Console,True)
        If Resultat = 0 Then
        Else
'MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
    Executer = Resultat
End Function
'------------------------------------------------
Function SimpleQuote(Str)
    SimpleQuote = ChrW(39) & Str & ChrW(39)
End Function
'------------------------------------------------
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'------------------------------------------------
Function Extracting_Videos(URL)
    Dim regEx, Match, Matches, Array_Videos,dico,K
    Set regEx = New RegExp
    regEx.Pattern = "<td>(.*?)</td><td>(.*?)</td><td><a href=.(.*?)"""
    regEx.IgnoreCase = True
    regEx.Global = False
    Set Matches = regEx.Execute(URL)
    Array_Videos = Array()
    Set dico = CreateObject("Scripting.Dictionary")
    For Each Match in Matches
        If Not dico.Exists(Match.Value) Then
            dico.Add Match.submatches(2),Match.submatches(2)
        End If
    Next
    For each K in dico.Keys()
        ReDim Preserve Array_Videos(UBound(Array_Videos) + 1)
        Array_Videos(UBound(Array_Videos)) = K
    Next
    Extracting_Videos = Array_Videos
End Function
'------------------------------------------------
Function GetFileName(URL)
    Dim ArrFile,FileName
    ArrFile = Split(URL,"/")
    FileName = ArrFile(UBound(ArrFile))
    GetFileName = FileName
End Function
'------------------------------------------------
Sub SmartCreateFolder(strFolder)
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(strFolder) then
            SmartCreateFolder(.getparentfoldername(strFolder))
            .CreateFolder(strFolder)
        End If
    End With
End Sub
'------------------------------------------------
Function GetSourceCode(URL)
    Dim http
    Set http = CreateObject("Msxml2.XMLHTTP")
    http.open "GET",URL,False
    http.send
    GetSourceCode = http.responseText
End Function
'------------------------------------------------
Function URLDecode(str)
Dim list,i,strLen,sT,depth,val,sR,by
set list = CreateObject("System.Collections.ArrayList")
strLen = Len(str)
    for i = 1 to strLen
        sT = mid(str, i, 1)
        if sT = "%" then
            if i + 2 <= strLen then
                list.Add cbyte("&H" & mid(str, i + 1, 2))
                i = i + 2
            end if
        else
            list.Add asc(sT)
        end if
    next
    depth = 0
    for each by in list.ToArray()
        if by and &h80 then
            if (by and &h40) = 0 then
                if depth = 0 then Err.Raise 5
                val = val * 2 ^ 6 + (by and &h3f)
                depth = depth - 1
                if depth = 0 then
                    sR = sR & chrw(val)
                    val = 0
                end if
            elseif (by and &h20) = 0 then
                if depth > 0 then Err.Raise 5
                val = by and &h1f
                depth = 1
            elseif (by and &h10) = 0 then
                if depth > 0 then Err.Raise 5
                val = by and &h0f
                depth = 2
            else
                Err.Raise 5
            end if
        else
            if depth > 0 then Err.Raise 5
            sR = sR & chrw(by)
        end if
    next
    if depth > 0 then Err.Raise 5
    URLDecode = sR
End Function
'------------------------------------------------

Merci de votre aide :king:

salut,

quand je lis ça, quelque chose me dit que tu n'es pas au bout de tes peines :mrgreen:

:salut:
J'ai pu m'avancer un peu dans ce projet :king:
Il me reste juste un problème d'encodage des caractères du titre de la vidèo
Par exemple comme celle-ci avec tout les caractères en arabe : https://www.youtube.com/watch?v=RDHwxj6IkrY
J'obtiens des caractères comme ça : "ÙƒØ±ÙŠÙ…_Ù…Ø§ÙÙŠØ¨Ø§Ù„ÙˆØ´_Ø¬Ø§Ø¨_Ø²ÙˆØ²_ØªÙˆØ§Ù…Ù‰"
et par la suite je ne peux pas l'enregistrer :x
YouTube_Downloader.vbs

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
Option Explicit
'ForceCScriptExecution
Dim Title,Converter,Youtube_URL,SourceCode,Videos,Video
Dim fso,ws,Download_Command,FileName,DEST,curDir,Temp,WaitingMsg
Title = "Youtube Downloader by Hackoo 2018"
Youtube_URL = InputBox("Veuillez saisir le lien de Youtube pour la conversion en lien direct et le télécharger" & vbcrlf & vbcrlf &_
"Please enter Youtube link for conversion to direct link and download it",Title,"https://www.youtube.com/watch?v=IJHPpTYtIqk")
If Youtube_URL = "" Then Wscript.Quit(1)
Converter="https://www.tubeoffline.to/downloadFrom.php?host=OnLine&video="&Youtube_URL
SourceCode = GetSourceCode(Converter)
Set ws = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
curDir = fso.GetParentFolderName(wscript.ScriptFullName)
Temp = ws.ExpandEnvironmentStrings("%Temp%")
Videos = Extracting_Videos(SourceCode)
DEST = curDir & "\YouTubeDownloader"
Call SmartCreateFolder(DEST)
 
For Each Video in Videos
    Video = Replace(unescape(unescape(Video)),"&amp;","&")
    Video = Replace(Video,"+","+")
    FileName = GetTitleVideo(video) & ".mp4"
    'FileName = Replace(FileName,"+","_")
    'FileName = Replace(FileName,"|","_")
    'FileName = Replace(FileName," ","_")
    'FileName = Replace(FileName,"'","_")
    'FileName = Replace(FileName,":","_")
    'FileName = Replace(FileName,",","_")
    'FileName = Replace(FileName,";","_")
    'FileName = Replace(FileName,"&","_")
    'FileName = Replace(FileName,chr(34),"_")
    FileName = unescape(unescape(FileName))
    WaitingMsg = DblQuote(FileName)
    Call CreateProgressBar(Title,WaitingMsg)
    Call LaunchProgressBar()
    'Download_Command = "Mode 100,3 & Title "& Title & "& color 0A & echo; & echo; & echo     Please be patient Downloading "& DblQuote(FileName) &_
    '"... & Powershell.exe -command ""(New-Object System.Net.WebClient).DownloadFile("& SimpleQuote(Video) & "," & SimpleQuote(DEST + "\" + FileName)&")"""
    'Call Executer(Download_Command,1)
    Call DownloadVideo(Video,DEST + "\" + FileName)
    Call CloseProgressBar()
    Explorer(DEST + "\" + FileName)
Next
'***********************************************************************
Function Executer(StrCmd,Console)
    Dim ws,MyCmd,Resultat
    Set ws = CreateObject("wscript.Shell")
'La valeur 0 pour cacher la console MS-DOS
    If Console = 0 Then
        MyCmd = "CMD /C " & StrCmd & ""
        Resultat = ws.run(MyCmd,Console,True)
        If Resultat = 0 Then
        Else
'MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
'La valeur 1 pour montrer la console MS-DOS
    If Console = 1 Then
        MyCmd = "CMD /C " & StrCmd & " "
        Resultat = ws.run(MyCmd,Console,True)
        If Resultat = 0 Then
        Else
'MsgBox "Une erreur inconnue est survenue !",16,"Une erreur inconnue est survenue !"
        End If
    End If
    Executer = Resultat
End Function
'------------------------------------------------
Function SimpleQuote(Str)
    SimpleQuote = ChrW(39) & Str & ChrW(39)
End Function
'------------------------------------------------
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'------------------------------------------------
Function Extracting_Videos(URL)
    Dim regEx, Match, Matches, Array_Videos,dico,K
    Set regEx = New RegExp
    regEx.Pattern = "<td>(.*?)</td><td>(.*?)</td><td><a href=.(.*?)"""
    regEx.IgnoreCase = True
    regEx.Global = False
    Set Matches = regEx.Execute(URL)
    Array_Videos = Array()
    Set dico = CreateObject("Scripting.Dictionary")
    For Each Match in Matches
        If Not dico.Exists(Match.Value) Then
            dico.Add Match.submatches(2),Match.submatches(2)
        End If
    Next
    For each K in dico.Keys()
        ReDim Preserve Array_Videos(UBound(Array_Videos) + 1)
        Array_Videos(UBound(Array_Videos)) = K
    Next
    Extracting_Videos = Array_Videos
End Function
'------------------------------------------------
Function GetFileName(URL)
    Dim ArrFile,FileName
    ArrFile = Split(URL,"/")
    FileName = ArrFile(UBound(ArrFile))
    GetFileName = FileName
End Function
'------------------------------------------------
Sub SmartCreateFolder(strFolder)
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(strFolder) then
            SmartCreateFolder(.getparentfoldername(strFolder))
            .CreateFolder(strFolder)
        End If
    End With
End Sub
'------------------------------------------------
Function GetSourceCode(URL)
    Dim http
    Set http = CreateObject("Msxml2.XMLHTTP")
    http.open "GET",URL,False
    http.send
    GetSourceCode = http.responseText
End Function
'------------------------------------------------
Sub ForceCScriptExecution()
    Dim Title, Arg, Str, cmd
    Title = "Youtube Downloader by Hackoo 2018                                                   "
    cmd = "CMD /C Title " & Title &" & color 0A & Mode 150,3 & "
    If Not LCase( Right( WScript.FullName, 12 ) ) = "\cscript.exe" Then
        For Each Arg In WScript.Arguments
            If InStr( Arg, " " ) Then Arg = """" & Arg & """"
            Str = Str & " " & Arg
        Next
        CreateObject( "WScript.Shell" ).Run _
           cmd & "cscript //nologo """ & _
            WScript.ScriptFullName & _
            """ " & Str
        WScript.Quit
    End If
End Sub
'-------------------------------------------------
Function GetTitleVideo(URL)
    Dim oRE, oMatches, Match,VideoTitle
    set oRE = New RegExp
    oRE.IgnoreCase = True
    oRE.Global = False
    oRE.Pattern = "title=(.+)"
    set oMatches = oRE.Execute(URL)
    If not isEmpty(oMatches) then
        For Each Match in oMatches  
            VideoTitle = Match.SubMatches(0)
        Next
        GetTitleVideo = VideoTitle
    End if
End Function
'-------------------------------------------------
Function URLDecode(StringToDecode)
Dim TempAns,CurChr
CurChr = 1
Do Until CurChr - 1 = Len(StringToDecode)
  Select Case Mid(StringToDecode, CurChr, 1)
    Case "+"
      TempAns = TempAns & " "
    Case "%"
      TempAns = TempAns & Chr(Clng("&h" & _
         Mid(StringToDecode, CurChr + 1, 2)))
       CurChr = CurChr + 2
    Case Else
      TempAns = TempAns & Mid(StringToDecode, CurChr, 1)
  End Select
 
CurChr = CurChr + 1
Loop
URLDecode = TempAns
End Function
' URLDecode function in Perl for reference
' both VB and Perl versions must return same
'
' sub urldecode{
'  local($val)=@_;
'  $val=~s/\+/ /g;
'  $val=~s/%([0-9A-H]{2})/pack('C',hex($1))/ge;
'  return $val;
' }
'-------------------------------------------------
Sub Explorer(File)
    ws.run "Explorer /n,/select,"& File &"",1,True
End Sub
'-------------------------------------------------
Sub DownloadVideo(URL,FileName)
    Dim WinHttp, arrArray, oFSO, oADO, iCount, oTextFile
    Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    If WinHttp Is Nothing Then Set WinHttp = CreateObject("WinHttp.WinHttpRequest")
    WinHttp.Open "GET", URL, False
    WinHttp.Send
    arrArray = WinHttp.ResponseBody
    Set WinHttp = Nothing
    On Error Resume Next
    Set oADO = CreateObject("ADODB.Stream")
    If oADO Is Nothing Then
'Write via FSO
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Set oTextFile = oFSO.OpenTextFile(Filename, 2, True)
        For iCount = 0 to UBound(arrArray)
            oTextFile.Write Chr(255 And Ascb(Midb(arrArray,iCount + 1, 1)))
        Next
        oTextFile.Close
    Else
'Write via ADO
        oADO.Type = 1
        oADO.Open
        oADO.Write arrArray
        oADO.SaveToFile Filename, 2
        oADO.Close
    End If
    Set oADO = Nothing
    Set oTextFile = Nothing
    Set oFSO = Nothing
End Sub
'-------------------------------------------------
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,-1)
    fhta.WriteLine "<HTML>"
    fhta.WriteLine "<meta charset=""UTF-8"" />"
    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 500,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 "'***********************************************************" 
    fhta.WriteLine "Function DblQuote(Str)"
    fhta.WriteLine "    DblQuote = Chr(34) & Str & Chr(34)"
    fhta.WriteLine "End Function"
    fhta.WriteLine "'***********************************************************"
    fhta.WriteLine "</script>"
    fhta.close
End Sub
'**********************************************************************************************
Sub LaunchProgressBar()
    Dim Launch
    Set ws = CreateObject("wscript.shell")
    Launch = Ws.run("mshta.exe " & Temp & "\Barre.hta",1,False)
End Sub
'**********************************************************************************************
Sub CloseProgressBar()
    Dim Close_HTA
    Set ws = CreateObject("wscript.shell")
    Close_HTA = Ws.Run("Taskkill /im ""mshta.exe"" /f",0,True)
End Sub
'**********************************************************************************************
Function DblQuote(Str)
    DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************