Dim ws, tempBase, today, bingXml, bingPic
Dim bingPicXmlUrl, bingPicUrl, resolution

resolution = "1920x1200"  '图片分辨率目前已知有1920x1200 1920x1080 1366x768 1280x768 1280x720 1024x768 800x600
tempBase = CreateObject("wscript.Shell").ExpandEnvironmentStrings("%temp%")
today=Replace(Date, "/", "-")
bingXml = tempBase& "\bingTemp"& today& "_"& resolution& ".xml"  '存放到系统临时目录
bingPic = tempBase&"\bingTemp"& today& "_"& resolution& ".jpg"
IF (CreateObject("Scripting.FileSystemObject").FileExists(bingPic)) Then
    Dim choice
    choice = MsgBox ("图片已存在, 是否重新下载?",4) '显示是否对话框
    If choice = 7 Then
        call setWallpaper(bingPic)
        Wscript.quit
    End If
End If



bingPicXmlUrl = parseBingPicXmlUrl()               '解析图片信息xml的url地址
call downloadFile(bingPicXmlUrl, bingXml)          '下载图片信息xml
bingPicUrl = parseBingPicUrl(bingXml)              '从xml中解析出图片url地址
call downloadFile(bingPicUrl, bingPic)             '下载图片
If (isPicFile(bingPic)) Then                       '检查是否是有效图片, 大部分图片都支持以上分辨率, 个别不支持某种分辨率, 下载的文件其实是html的报错页面
    call setWallpaper(bingPic)                     '设为桌面壁纸
Else
    MsgBox "指定分辨率的图片找不到, 请切换分辨率"
End IF
Wscript.quit

'======================================================================
Function parseBingPicXmlUrl()
    Dim dayOffset
    If WScript.Arguments.Count = 0 Then
        dayOffset = 0
    Else 
        dayOffset = Wscript.Arguments(0)
    End If
    parseBingPicXmlUrl = "http://www.bing.com/HPImageArchive.aspx?format=xml&idx=" & dayOffset & "&n=8&pid=hp"
    'dayOffset表示距今多少天, 如输入1表示昨天
    '改地址来源: 打开bing主页cn.bing.com, 查看homepageimgviewer.js, 查看getImageData函数, 里面有构造url的方法
End Function

Sub downloadFile(url, savePath)
    Dim obj1,obj2
    Set obj1 = CreateObject("msxml2.xmlhttp")
    Set obj2 = CreateObject("adodb.stream")
    obj1.open "get",url,False
    obj1.send
    obj2.Type = 1
    obj2.Mode = 3
    obj2.Open()
    obj2.Write(obj1.responseBody)
    obj2.SaveToFile savePath,2  '2的意思是覆盖文件
    obj2.Close
    Set obj1 = Nothing
End Sub

Function parseBingPicUrl(bingXml)
    Dim xmlDoc, bingPicUrl
    Set xmlDoc = CreateObject("Microsoft.XMLDOM")
    xmlDoc.async = False
    xmlDoc.load(bingXml)
    parseBingPicUrl = "http://cn.bing.com" & xmlDoc.getElementsByTagName("urlBase")(0).childNodes(0).nodeValue & "_"& resolution & ".jpg"
End Function

Function isPicFile(picPath)
    Dim obj, char1, char2
    Set obj = CreateObject("ADODB.Stream")
    obj.Type = 1
    obj.Mode = 3
    obj.Open()
    obj.LoadFromFile picPath
    If AscB(obj.Read(1)) = &HFF And AscB(obj.Read(1)) = &HD8 Then
        isPicFile = True
    Else
        isPicFile = False
    End If
End Function

Sub setWallpaper(picPath)
    Dim shApp, picFile, items
    Set shApp = CreateObject("Shell.Application")
    Set picFile = CreateObject("Scripting.FileSystemObject").GetFile(bingPic)
    Set items = shApp.NameSpace(picFile.ParentFolder.Path).ParseName(picFile.Name).Verbs
    For Each item In items
      If item.Name = "设置为桌面背景(&B)" Then item.DoIt
    Next
    WScript.Sleep 5000
End Sub
复制代码