[VBS] Daily Downloading NASA images to use as Windows wallpaper

Option Explicit  
'Vbscript created by Hackoo on 16/01/2020 inspired by this batch file  
'https://codereview.stackexchange.com/questions/213724/download-nasa-images-to-use-as-windows-wallpaper/235545#235545  
'Run as Admin  
If Not WScript.Arguments.Named.Exists("elevate") Then  
   CreateObject("Shell.Application").ShellExecute DblQuote(WScript.FullName) _  
   , DblQuote(WScript.ScriptFullName) & " /elevate", "", "runas", 1  
    WScript.Quit  
End If  
  
Dim Title,BaseUrl,dte,URL,Ws,objFSO,Command,i,LogFile,strText,Img  
Dim WinHttp,Data,ImgLink,strDirectory,sWallPaper,ID,FilePath,TaskName,Repeat_Task  
Title = "Download Daily NASA image and set as Windows Wallpaper by Hackoo"  
Set objFSO = CreateObject("Scripting.FileSystemObject")  
Set Ws = CreateObject("WScript.Shell")  
strDirectory = "Wallpaper"  
strDirectory = objFSO.BuildPath(Ws.SpecialFolders("Desktop"), strDirectory)  
If not objFSO.FolderExists(strDirectory) Then objFSO.CreateFolder(strDirectory)  
LogFile = strDirectory & "\Wallpaper_Error_Log.txt"  
BaseUrl="https://apod.nasa.gov/apod/"  
dte = Right(Year(Now),2) & LPad(Month(Now),2,"0") & LPad(Day(Now),2,"0")  
URL = BaseUrl & "ap" & dte &".html"  
'wscript.echo url  
FilePath = WScript.ScriptFullName  
TaskName = "NASA"  
Repeat_Task = 120  
Call Create_Schedule_Task(Repeat_Task,TaskName,FilePath)  
Set WinHttp = CreateObject("Microsoft.XmlHttp")  
On error resume next  
WinHttp.Open "GET", URL, False  
WinHttp.send()  
  
If Err Then Call WriteError()  
  
If WinHttp.Status = 200 Then  
    If InStr(WinHttp.responseText,"embed") > 0 Then  
		ID = ExtractMatch(WinHttp.responseText,"embed/([A-Za-z0-9-_]+)")  
		ImgLink = "https://i.ytimg.com/vi/"& ID &"/maxresdefault.jpg" ' Get Image from Youtube video  
		'wscript.echo ImgLink  
		sWallPaper = strDirectory & "\YT_" & dte &".jpg"  
		'ws.run ImgLink  
		Call Download(ImgLink,sWallPaper)  
		If objFSO.FileExists(sWallPaper) Then Call SetWallpaper(sWallPaper)  
	Else  
		Img = ExtractMatch(WinHttp.responseText," 0 then  
		Call WriteError()  
        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  
'-------------------------------------------------------------------------  
Sub SetWallpaper(sWallPaper)  
' Update in registry  
' Mise à jour dans le registre  
Ws.RegWrite "HKCU\Control Panel\Desktop\Wallpaper", sWallPaper  
' Killing not responding processes  
Ws.Run "CMD /C Taskkill /f /fi ""status eq not responding""",0,True  
' Let the system know about the change  
' Informer le système du changement  
For i=0 to 2  
	Ws.Run "RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", i, False  
	Ws.Run "RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", i, False  
	Ws.Run "RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", i, True  
	Ws.Run "RUNDLL32.EXE user32.dll,UpdatePerUserSystemParameters", i, True  
Next  
End Sub  
'-------------------------------------------------------------------------  
Function ExtractMatch(Text,Pattern)  
    Dim Regex, Matches  
    Set Regex = New RegExp  
    Regex.Pattern = Pattern  
	Regex.Global = True  
	Regex.IgnoreCase = True   
    Set Matches = Regex.Execute(Text)  
    If Matches.Count = 0 Then  
        ExtractMatch = ""  
        Exit Function  
    End If  
    ExtractMatch = Matches(0).SubMatches(0)  
End Function  
'-------------------------------------------------------------------------  
Function LPad(s, l, c)  
  Dim n : n = 0  
  If l > Len(s) Then n = l - Len(s)  
  LPad = String(n, c) & s  
End Function  
'-------------------------------------------------------------------------  
Function GetFileNamefromDirectLink(URL)  
    Dim ArrFile,FileName  
    ArrFile = Split(URL,"/")  
    FileName = ArrFile(UBound(ArrFile))  
    GetFileNamefromDirectLink = FileName  
End Function  
'-------------------------------------------------------------------------  
Function Dblquote(str)  
    Dblquote = chr(34) & str & chr(34)  
End Function  
'-------------------------------------------------------------------------  
Sub WriteLog(strText,LogFile)  
    Dim fs,ts  
    Const ForAppending = 8  
    Set fs = CreateObject("Scripting.FileSystemObject")  
    Set ts = fs.OpenTextFile(LogFile,ForAppending,True)  
    ts.WriteLine strText  
    ts.Close  
End Sub  
'-------------------------------------------------------------------------  
Function Get_Date_Time()  
	Get_Date_Time = LPad(Day(Now),2,"0") & "/" & LPad(Month(Now),2,"0") & "/" & Year(Now) &_  
	vbTab & LPad(Hour(Now),2,"0") & ":" & LPad(Minute(Now),2,"0")  & ":" & LPad(Second(Now),2,"0")  
End Function  
'-------------------------------------------------------------------------  
Sub Create_Schedule_Task(Repeat_Task,TaskName,FilePath)  
Dim Task,Result  
Task = "CMD /C Schtasks /Create /SC DAILY /ST 08:00 /F /RI "&_  
Repeat_Task &" /DU 24:00 /TN "& TaskName &" /TR "& FilePath &""  
Result = Ws.run(Task,0,True)  
End Sub  
'-------------------------------------------------------------------------  
Sub WriteError()  
	Dim Line  
	Line  = Get_Date_Time  
	Line  = Line &  vbcrlf & "Error " & err.number & " (0x" & hex(err.number) & ") " & vbcrlf &_  
	err.Description  
	Line  = Line & "Source : " & err.Source  
	WriteLog Line & vbcrlf & String(70,"-") , LogFile  
	Err.clear  
End Sub  
'------------------------------------------------------------------------

For any update of this vbscript NASA_Wallpaper.vbs