[原创] VBS下载bing壁纸，并设为桌面壁纸

bjc5233

vbs代码比较简单【挺少写vbs的，代码结构不咋样啊】，主要是下载
至于怎么找到bing壁纸源那就得看bing网站JS源码
这版的代码删了

====================2014.10.27更新===================
现在只需要纯vbs脚本来实现功能
新地址：http://pan.baidu.com/s/1pJqgdHT
这版的代码删了

====================2014.10.28更新===================
调整结构，看起来更清晰
这版的代码也删了

====================2014.11.01更新===================
1.尝试了一下，发现bing壁纸支持的分辨率挺多的啊，就把这个也加进来，可以下载指定分辨率
2.当指定日期指定分辨率壁纸已经下载，会提示是否重新下载
3.感谢zz100001的挽尊，哈哈
新地址：http://pan.baidu.com/s/1eQIiPii

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
复制代码

Batcher

可以试试这几个代码能否设置桌面壁纸，如果可以的话就能摆脱对exe的依赖了。
http://bbs.bathome.net/viewthread.php?tid=3345#pid21158

bjc5233

回复 2# Batcher


   谢谢提示啊，经过我测试，那个代码确实可以将jpg文件作为桌面壁纸，
但是设置之后，就不能使用图片右键“设置为桌面壁纸”，也不能使用“个性化-桌面背景”，好像也不能更换壁纸

   之后采用了vbs调用图片右键菜单的方式来设置桌面壁纸，这样就只需要vbs脚本了
更新后地址：http://pan.baidu.com/s/1pJqgdHT

Batcher

直接把代码放到顶楼吧，方便大家查看。

zz100001

要喜欢这壁纸最好还是装个必应缤纷桌面吧，用一年多了感觉还不错。
你找到的这个其实是bing的网页背景，不是真正的壁纸，图片质量差了很多，把format换成js，得到的 JSON.images[i].hsh 就是那个真正的壁纸，
比如今天的那只鸡鸡，就可以用这个地址得到 http://cn.bing.com/hpwp/574bfb828a3bead10ea09cc4dd36709f

bjc5233

回复 5# zz100001

谢谢关注哈，那天的不知什么鸡，我看了下用你说的地址下载得到的分辨率是1920X1200，大小是431kb；
vbs工具下载的1920X1200分辨率的也是431kb，图片质量应该是一样的，你用的可能不是最新的代码吧？
我还特意测试了下今天的，是一样的哈
以前是看到formate有js和xml两种，不过考虑到vbs解析xml方便，就没去看js的