每日更换壁纸为必应壁纸vbs脚本

Option Explicit

' ================= 配置区域 =================
Dim wsh, SaveFolder
Set wsh = CreateObject("WScript.Shell")
' 设置保存图片的文件夹路径
SaveFolder = wsh.ExpandEnvironmentStrings("%USERPROFILE%") & "\Pictures\BingWallpapers"
Set wsh = Nothing
' ===========================================

Dim objFSO, objShell, objHTTP, objStream
Dim apiUrl, jsonText, imgUrl, fileName, localPath
Dim regPath, ws

' 1. 初始化对象
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("WScript.Shell")
Set ws = CreateObject("WScript.Shell")

' 2. 清理并创建保存目录
' 如果文件夹存在，则删除整个文件夹
If objFSO.FolderExists(SaveFolder) Then
    objFSO.DeleteFolder SaveFolder, True ' True 表示强制删除只读文件或非空文件夹
End If

' 重新创建全新的空文件夹
objFSO.CreateFolder SaveFolder

' 3. 获取 Bing API 数据
apiUrl = "https://www.bing.com/HPImageArchive.aspx?format=js&idx=0&n=1&mkt=zh-CN"
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
objHTTP.Open "GET", apiUrl, False
objHTTP.Send

If objHTTP.Status = 200 Then
    jsonText = objHTTP.ResponseText

    ' 4. 解析 JSON 提取图片 URL
    Dim urlStart, urlEnd, rawUrl
    urlStart = InStr(jsonText, """url"":""") + 7
    If urlStart > 7 Then
        urlEnd = InStr(urlStart, jsonText, """")
        rawUrl = Mid(jsonText, urlStart, urlEnd - urlStart)
        
        ' 尝试获取更高清的UHD版本 (4K)，如果不行则回退到原图
        If InStr(rawUrl, "1920x1080") > 0 Then
            imgUrl = "https://www.bing.com" & Replace(rawUrl, "1920x1080", "UHD")
        Else
            imgUrl = "https://www.bing.com" & rawUrl
        End If

        ' 5. 确定文件名 (使用当前日期命名，格式：bing_YYYYMMDD.jpg)
        fileName = "bing_" & Year(Date) & Right("0" & Month(Date), 2) & Right("0" & Day(Date), 2) & ".jpg"
        localPath = SaveFolder & "\" & fileName

        ' 6. 下载图片
        Set objHTTP = Nothing
        Set objHTTP = CreateObject("MSXML2.XMLHTTP")
        objHTTP.Open "GET", imgUrl, False
        objHTTP.Send
        
        If objHTTP.Status = 200 Then
            Set objStream = CreateObject("ADODB.Stream")
            objStream.Type = 1 ' adTypeBinary
            objStream.Open
            objStream.Write objHTTP.ResponseBody
            objStream.SaveToFile localPath, 2 ' adSaveCreateOverWrite
            objStream.Close
            Set objStream = Nothing
            
            ' 7. 设置为桌面壁纸
            regPath = "HKEY_CURRENT_USER\Control Panel\Desktop\"
            ws.RegWrite regPath & "Wallpaper", localPath, "REG_SZ"
            ws.RegWrite regPath & "WallpaperStyle", "2", "REG_SZ" ' 2=拉伸, 6=适应, 10=填充
            ws.RegWrite regPath & "TileWallpaper", "0", "REG_SZ"
            
            ' 刷新桌面
            ws.Run "rundll32.exe user32.dll,UpdatePerUserSystemParameters", 0, True
        End If
    End If
End If

' 清理对象
Set objHTTP = Nothing
Set objFSO = Nothing
Set objShell = Nothing
Set ws = Nothing

另存为 .vbs
使用win自带的任务计划，运行此脚本，每日自动获取必应4k壁纸并设置为桌面

1 个帖子 - 1 位参与者

阅读完整话题