Last active
July 16, 2023 01:25
-
-
Save cwillsey06/7cc7301a100075abbdcb46e64fded3a0 to your computer and use it in GitHub Desktop.
Public-domain Bing wallpaper fetcher & setter
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| ' This is free and unencumbered software released into the public domain. | |
| ' | |
| ' Anyone is free to copy, modify, publish, use, compile, sell, or | |
| ' distribute this software, either in source code form or as a compiled | |
| ' binary, for any purpose, commercial or non-commercial, and by any | |
| ' means. | |
| Option Explicit | |
| Dim wShell: Set wShell = CreateObject("WScript.Shell") | |
| Dim wTemp: wTemp = wShell.ExpandEnvironmentStrings("%TEMP%") | |
| Dim Url | |
| Const BaseUrl = "https://www.bing.com/" | |
| Const ApiUrl = "https://www.bing.com/HPImageArchive.aspx?format=xml&idx=0&n=1&mkt=en-UShttp" | |
| Private Sub GetImageUrl() | |
| Dim xHttp: Set xHttp = CreateObject("MSXML2.XMLHTTP") | |
| Call xHttp.Open("GET", ApiUrl, False) | |
| xHttp.Send | |
| Dim DOMDocument: Set DOMDocument = CreateObject("MSXML2.DOMDocument") | |
| DOMDocument.LoadXML(xHttp.ResponseText) | |
| Dim ImagePath: Set ImagePath = DOMDocument.selectSingleNode("//image/url") | |
| Url = BaseUrl & ImagePath.Text | |
| End Sub | |
| Private Sub DownloadImage() | |
| Dim xHttp: Set xHttp = CreateObject("MSXML2.XMLHTTP") | |
| Call xHttp.Open("GET", Url, False) | |
| xHttp.Send | |
| Dim bStrm: Set bStrm = CreateObject("Adodb.Stream") | |
| With bStrm | |
| .Type = 1 | |
| .Open | |
| .Write xHttp.ResponseBody | |
| .SaveToFile wTemp & "/bing_wallpaper.jpg", 2 | |
| End With | |
| End Sub | |
| Private Sub SetWallpaperImage() | |
| wShell.Exec("powershell.exe " _ | |
| & "-Command Set-ItemProperty " _ | |
| & "-Path 'HKCU:Control Panel\Desktop' " _ | |
| & "-Name 'WallPaper' " _ | |
| & "-Value " & wTemp & "\bing_wallpaper.jpg; " _ | |
| & "rundll32.exe user32.dll UpdatePerUserSystemParameters" _ | |
| ) | |
| End Sub | |
| GetImageUrl() | |
| DownloadImage() | |
| SetWallpaperImage() |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment