Board logo

标题: [原创] VBS下载bing壁纸,并设为桌面壁纸 [打印本页]

作者: bjc5233    时间: 2014-10-27 03:51     标题: VBS下载bing壁纸,并设为桌面壁纸

本帖最后由 bjc5233 于 2014-11-1 11:42 编辑

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
  1. Dim ws, tempBase, today, bingXml, bingPic
  2. Dim bingPicXmlUrl, bingPicUrl, resolution
  3. resolution = "1920x1200"  '图片分辨率目前已知有1920x1200 1920x1080 1366x768 1280x768 1280x720 1024x768 800x600
  4. tempBase = CreateObject("wscript.Shell").ExpandEnvironmentStrings("%temp%")
  5. today=Replace(Date, "/", "-")
  6. bingXml = tempBase& "\bingTemp"& today& "_"& resolution& ".xml"  '存放到系统临时目录
  7. bingPic = tempBase&"\bingTemp"& today& "_"& resolution& ".jpg"
  8. IF (CreateObject("Scripting.FileSystemObject").FileExists(bingPic)) Then
  9.     Dim choice
  10.     choice = MsgBox ("图片已存在, 是否重新下载?",4) '显示是否对话框
  11.     If choice = 7 Then
  12.         call setWallpaper(bingPic)
  13.         Wscript.quit
  14.     End If
  15. End If
  16. bingPicXmlUrl = parseBingPicXmlUrl()               '解析图片信息xml的url地址
  17. call downloadFile(bingPicXmlUrl, bingXml)          '下载图片信息xml
  18. bingPicUrl = parseBingPicUrl(bingXml)              '从xml中解析出图片url地址
  19. call downloadFile(bingPicUrl, bingPic)             '下载图片
  20. If (isPicFile(bingPic)) Then                       '检查是否是有效图片, 大部分图片都支持以上分辨率, 个别不支持某种分辨率, 下载的文件其实是html的报错页面
  21.     call setWallpaper(bingPic)                     '设为桌面壁纸
  22. Else
  23.     MsgBox "指定分辨率的图片找不到, 请切换分辨率"
  24. End IF
  25. Wscript.quit
  26. '======================================================================
  27. Function parseBingPicXmlUrl()
  28.     Dim dayOffset
  29.     If WScript.Arguments.Count = 0 Then
  30.         dayOffset = 0
  31.     Else
  32.         dayOffset = Wscript.Arguments(0)
  33.     End If
  34.     parseBingPicXmlUrl = "http://www.bing.com/HPImageArchive.aspx?format=xml&idx=" & dayOffset & "&n=8&pid=hp"
  35.     'dayOffset表示距今多少天, 如输入1表示昨天
  36.     '改地址来源: 打开bing主页cn.bing.com, 查看homepageimgviewer.js, 查看getImageData函数, 里面有构造url的方法
  37. End Function
  38. Sub downloadFile(url, savePath)
  39.     Dim obj1,obj2
  40.     Set obj1 = CreateObject("msxml2.xmlhttp")
  41.     Set obj2 = CreateObject("adodb.stream")
  42.     obj1.open "get",url,False
  43.     obj1.send
  44.     obj2.Type = 1
  45.     obj2.Mode = 3
  46.     obj2.Open()
  47.     obj2.Write(obj1.responseBody)
  48.     obj2.SaveToFile savePath,2  '2的意思是覆盖文件
  49.     obj2.Close
  50.     Set obj1 = Nothing
  51. End Sub
  52. Function parseBingPicUrl(bingXml)
  53.     Dim xmlDoc, bingPicUrl
  54.     Set xmlDoc = CreateObject("Microsoft.XMLDOM")
  55.     xmlDoc.async = False
  56.     xmlDoc.load(bingXml)
  57.     parseBingPicUrl = "http://cn.bing.com" & xmlDoc.getElementsByTagName("urlBase")(0).childNodes(0).nodeValue & "_"& resolution & ".jpg"
  58. End Function
  59. Function isPicFile(picPath)
  60.     Dim obj, char1, char2
  61.     Set obj = CreateObject("ADODB.Stream")
  62.     obj.Type = 1
  63.     obj.Mode = 3
  64.     obj.Open()
  65.     obj.LoadFromFile picPath
  66.     If AscB(obj.Read(1)) = &HFF And AscB(obj.Read(1)) = &HD8 Then
  67.         isPicFile = True
  68.     Else
  69.         isPicFile = False
  70.     End If
  71. End Function
  72. Sub setWallpaper(picPath)
  73.     Dim shApp, picFile, items
  74.     Set shApp = CreateObject("Shell.Application")
  75.     Set picFile = CreateObject("Scripting.FileSystemObject").GetFile(bingPic)
  76.     Set items = shApp.NameSpace(picFile.ParentFolder.Path).ParseName(picFile.Name).Verbs
  77.     For Each item In items
  78.       If item.Name = "设置为桌面背景(&B)" Then item.DoIt
  79.     Next
  80.     WScript.Sleep 5000
  81. End Sub
复制代码

作者: Batcher    时间: 2014-10-27 09:14

可以试试这几个代码能否设置桌面壁纸,如果可以的话就能摆脱对exe的依赖了。
http://bbs.bathome.net/viewthread.php?tid=3345#pid21158
作者: bjc5233    时间: 2014-10-27 13:50

回复 2# Batcher


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

   之后采用了vbs调用图片右键菜单的方式来设置桌面壁纸,这样就只需要vbs脚本了
更新后地址:http://pan.baidu.com/s/1pJqgdHT
作者: Batcher    时间: 2014-10-27 14:13

直接把代码放到顶楼吧,方便大家查看。
作者: zz100001    时间: 2014-10-30 16:53

本帖最后由 zz100001 于 2014-10-30 17:01 编辑

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

回复 5# zz100001

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




欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2