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
'------------------------------------------------ |
Partager