Hi 😎
I created a vbscript that was inspired by a batch file (Daily Downloading NASA images to use as Windows wallpaper)
So the vbscript try to download everyday a new picture and set it as wallpaper from here ==> Astronomy Picture of the Day.
Examples :
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,"<img.*?src=\x22(\w.+)\x22") imglink="BaseUrl" &="" img="" 'wscript.echo="" swallpaper="strDirectory" "\"="" dte="" "_"="" getfilenamefromdirectlink(imglink)="" call="" download(imglink,swallpaper)="" if="" objfso.fileexists(swallpaper)="" then="" setwallpaper(swallpaper)="" end="" else="" strtext="Get_Date_Time" vbtab="" &_="" "the="" wallpaper="" is="" not="" ready="" until="" now="" !"="" vbcrlf="" string(70,"-")="" writelog(strtext,logfile)="" wscript.quit(1)="" '-------------------------------------------------------------------------="" sub="" download(url,save2file)="" dim="" file,line,bs,ws="" on="" error="" resume="" next="" set="" file="CreateObject("Microsoft.XmlHttp")" file.open="" "get",url,="" false="" file.send()="" err.number="" <=""> 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
'------------------------------------------------------------------------</img.*?src=\x22(\w.+)\x22")>
For any update of this vbscript NASA_Wallpaper.vbs