【分享】让你的桌面背景每天自动更新高清高质量的壁纸（from bing）

无·法 2014-11-25 09:24:36
必应搜索最吸引人的地方不是它的搜索，而是它每天更新的精美高清壁纸。如果能把这壁纸每天自动设置为我们电脑桌面背景就好了。



把下面这个代码保存到标准模块就可以了，不用窗体等模块，设置工程从sub main启动。编译成exe文件设置到启动项。 这样每天打开电脑都有耳目一新的感觉了。



Option Explicit



Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long

Dim strAppPath As String  '应用程序目录

Const BING_PICTURE_DIR = "C:\Bing\"

Dim strWallPaperLocal As String



Sub Main()

    App.TaskVisible = False

    If App.PrevInstance Then End

    strAppPath = App.Path

    If Right(strAppPath, 1) <> "\" Then strAppPath = strAppPath & "\"

    

    Do

        Call checkLocalPicture

        delay 5 '延时5秒

    Loop

End Sub

'每隔5秒读取检测下本地是否有当日壁纸文件，没有的话就去网络下载

Private Sub checkLocalPicture()

    If Dir(BING_PICTURE_DIR, vbDirectory) = "" Then MkDir BING_PICTURE_DIR

    strWallPaperLocal = BING_PICTURE_DIR & Format(Now, "yyyymmdd") & ".jpg"

    If Dir(strWallPaperLocal) = "" And InternetCheckConnection("http://cn.bing.com/", &H1, 0&) <> 0 Then Call flushWallPaper

End Sub

'更新墙纸

Private Sub flushWallPaper()

    Dim strWallPaperUrl$

    strWallPaperUrl = getWallPaperUrl()

    DownLoadNetFile strWallPaperUrl, strWallPaperLocal

    SavePicture LoadPicture(strWallPaperLocal), BING_PICTURE_DIR & "Wallpaper1.bmp"

    SystemParametersInfo ByVal 20, True, ByVal BING_PICTURE_DIR & "Wallpaper1.bmp", 1

    Shell "rundll32 user32,UpdatePerUserSystemParameters"

End Sub

'下载图片文件

Function DownLoadNetFile(ByVal strUrl As String, ByVal FileNa As String)

    Dim XmlHttp, Temp() As Byte

    Set XmlHttp = CreateObject("Microsoft.XMLHTTP")

    XmlHttp.Open "GET", strUrl, False

    XmlHttp.SEnd

    If XmlHttp.ReadyState = 4 Then

        Temp() = XmlHttp.ResponseBody

        Open FileNa For Binary As #1

        Put #1, , Temp()

        Close #1

    End If

    Set XmlHttp = Nothing

End Function

'得到页面源代码

Private Function getHtmlStr(strUrl As String) As String

    On Error GoTo err1

    Dim XmlHttp As Object

    Set XmlHttp = CreateObject("Microsoft.XMLHTTP")

    XmlHttp.Open "GET", strUrl, False

    XmlHttp.SEnd

    getHtmlStr = StrConv(XmlHttp.ResponseBody, vbUnicode)

    Set XmlHttp = Nothing

    

    Exit Function

err1:

    MsgBox Err.Number & vbCrLf & Err.Description, "getHtmlStr()"

End Function

'得到墙纸的url地址

Private Function getWallPaperUrl() As String

    Dim strData As String

    Dim reg As Object

    Dim matchs As Object, match As Object

    

    strData = getHtmlStr("http://cn.bing.com/")

    

    If strData = "" Then

        Do While strData = ""

            strData = getHtmlStr("http://cn.bing.com/")

        Loop

    End If

    Set reg = CreateObject("vbscript.regExp")

    reg.Global = True

    reg.Pattern = "g_img={url:'(.*?)'"

    Set matchs = reg.Execute(strData)

    If matchs.Count > 0 Then getWallPaperUrl = Replace(matchs(0).SubMatches(0), "1366x768", "1920x1080") ' getWallPaperUrl = matchs(0).SubMatches(0)

End Function

'延时函数，单位为秒

Private Sub delay(delaySeconds As Long)

    Dim lngFinish As Long

    lngFinish = Timer + delaySeconds

    Do While Timer < lngFinish

        DoEvents

    Loop

End Sub


工程及exe文件打包直接下载：
http://download.csdn.net/detail/sysdzw/8194927
...全文
5159 21 打赏 收藏 转发到动态 举报
写回复
用AI写文章
21 条回复
切换为时间正序
请发表友善的回复…
发表回复
无·法 2016-06-12
  • 打赏
  • 举报
 回复
引用 20 楼 xpj_4901 的回复:
新的问题又出来啦！ 请教下： bing的官方API： xml版：http://cn.bing.com/HPImageArchive.aspx?idx=0&n=1 json版：http://cn.bing.com/HPImageArchive.aspx?format=js&idx=0&n=1 两个源，得到的两个url指向的图片分辨率不一样 比如6月12日的： xml：/az/hprichbg/rb/MtDurmitorIceCave_ZH-CN11432825802_1366x768.jpg json：http://s.cn.bing.net/az/hprichbg/rb/MtDurmitorIceCave_ZH-CN11432825802_1920x1080.jpg 下载回来后，xml的是1366x768，json的是1920x1080 为什么？
不知道啊，要么就直接用json的呗，要么就改呗
xpj_4901 2016-06-12
  • 打赏
  • 举报
 回复
新的问题又出来啦！ 请教下： bing的官方API： xml版：http://cn.bing.com/HPImageArchive.aspx?idx=0&n=1 json版：http://cn.bing.com/HPImageArchive.aspx?format=js&idx=0&n=1 两个源，得到的两个url指向的图片分辨率不一样 比如6月12日的： xml：/az/hprichbg/rb/MtDurmitorIceCave_ZH-CN11432825802_1366x768.jpg json：http://s.cn.bing.net/az/hprichbg/rb/MtDurmitorIceCave_ZH-CN11432825802_1920x1080.jpg 下载回来后，xml的是1366x768，json的是1920x1080 为什么？
无·法 2016-06-11
  • 打赏
  • 举报
 回复
引用 18 楼 xpj_4901 的回复:
还是期待大神能来个更简洁的，桌面直接运行的。 想利用vbs、js脚本实现。 直接把vb源码改成vbs，无法运行。 必应壁纸每天换.vbs 或 必应壁纸每天换.js
因为那个有bug，然后删除掉了。 延时函数有问题，始终出不去，会导致第二天到了也没法自动更新桌面，只有重新运行。 新的没bug了，下载地址：http://download.csdn.net/detail/sysdzw/9545847
xpj_4901 2016-06-11
  • 打赏
  • 举报
 回复
还是期待大神能来个更简洁的，桌面直接运行的。 想利用vbs、js脚本实现。 直接把vb源码改成vbs，无法运行。 必应壁纸每天换.vbs 或 必应壁纸每天换.js
xpj_4901 2016-06-11
  • 打赏
  • 举报
 回复
端午节闲来无事，参照大神的源码，利用bing的官方API（xml版：http://cn.bing.com/HPImageArchive.aspx?idx=0&n=1），修改了下大神源码：win7 64位顺利运行。 就差编译成exe了。 另：大神的 更新v1.0.36 下载不了，下载地址（http://download.csdn.net/detail/sysdzw/9545310）404找不到 
Option Explicit

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" (ByVal lpszUrl As String, ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Dim strAppPath As String  '应用程序目录
Const BING_PICTURE_DIR = "F:\图片\壁纸3\"
Dim strWallPaperLocal As String '今日本地壁纸文件地址

Sub Main()
    Dim flag As Boolean
    App.TaskVisible = False
    If App.PrevInstance Then End
    strAppPath = App.Path
    If Right(strAppPath, 1) <> "\" Then strAppPath = strAppPath & "\"
    
    strWallPaperLocal = BING_PICTURE_DIR & Format(Now, "yyyymmdd") & ".jpg"
     '每隔5秒读取检测下本地是否有当日壁纸文件，没有的话就去网络下载
    flag = False
    Do
        checkLocalPicture
        delay 20 '延时20秒
        If Dir(strWallPaperLocal) = "" Then flag = True
    Loop While flag = True
        
End Sub

'统一文件名：20160126.jpg
Private Sub checkLocalPicture()
    If Dir(BING_PICTURE_DIR, vbDirectory) = "" Then MkDir BING_PICTURE_DIR
    If Dir(strWallPaperLocal) = "" And InternetCheckConnection("http://cn.bing.com/", &H1, 0&) <> 0 Then
    flushWallPaper
        End If
End Sub
'更新墙纸
Private Sub flushWallPaper()
    Dim strWallPaperUrl$
    strWallPaperUrl = getWallPaperUrl()
    DownLoadNetFile strWallPaperUrl, strWallPaperLocal
    SavePicture LoadPicture(strWallPaperLocal), BING_PICTURE_DIR & "Wallpaper1.bmp"
    SystemParametersInfo ByVal 20, True, ByVal BING_PICTURE_DIR & "Wallpaper1.bmp", 1
    Shell "rundll32 user32,UpdatePerUserSystemParameters"
End Sub
'下载图片文件
Function DownLoadNetFile(ByVal strUrl As String, ByVal FileNa As String)
    Dim XmlHttp, Temp() As Byte
    Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
    XmlHttp.Open "GET", strUrl, False
    XmlHttp.send
    If XmlHttp.readyState = 4 Then
        Temp() = XmlHttp.responseBody
        Open FileNa For Binary As #1
        Put #1, , Temp()
        Close #1
    End If
    Set XmlHttp = Nothing
End Function
'得到页面源代码
Private Function getHtmlStr(strUrl As String) As String
    On Error GoTo err1
    
    Dim XmlHttp As Object
    Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
    XmlHttp.Open "GET", strUrl, False
    XmlHttp.send
    getHtmlStr = StrConv(XmlHttp.responseBody, vbUnicode)

    Set XmlHttp = Nothing
    
    Exit Function
err1:
    MsgBox Err.Number & vbCrLf & Err.Description, "getHtmlStr()"
End Function
'得到墙纸的url地址
Private Function getWallPaperUrl() As String
    Dim strData As String
    Dim xmldoc As DOMDocument
    Dim tra As Object
    Dim traNode As Object
    Set xmldoc = New DOMDocument
    
    xmldoc.Load ("http://cn.bing.com/HPImageArchive.aspx?idx=0&n=1")
  
   ' xmldoc
    'Set tra = xmldoc.selectSingleNode("images")
    Set tra = xmldoc.getElementsByTagName("url")
    delay (1)
    Set traNode = tra.Item(0)
    getWallPaperUrl = "http://cn.bing.com" + traNode.Text
    
    Set traNode = Nothing
    Set tra = Nothing
    Set xmldoc = Nothing
   'MsgBox (getWallPaperUrl)

End Function
'延时函数，单位为秒
Private Sub delay(delaySeconds As Long)
    Dim lngFinish As Long
    lngFinish = Timer + delaySeconds
    Do While Timer < lngFinish
        DoEvents
    Loop
End Sub
无·法 2016-06-10
  • 打赏
  • 举报
 回复
更新v1.0.36 更新说明： 现在不适用正则了。通过json接口地址获得页面代码纯字符串截取内容。 下载地址： http://download.csdn.net/detail/sysdzw/9545310
无·法 2016-06-09
  • 打赏
  • 举报
 回复
引用 14 楼 xpj_4901 的回复:
有个bing的官方API： xml版：http://cn.bing.com/HPImageArchive.aspx?idx=0&n=1 json版：http://cn.bing.com/HPImageArchive.aspx?format=js&idx=0&n=1 可以直接获取图片地址。。 以上来自知乎 https://www.zhihu.com/question/37582333
原来还有这样的办法。 我那个是从源代码里分析得出的，用正则表达式提取出网址的。 你直接运行exe报错吗？
xpj_4901 2016-06-09
  • 打赏
  • 举报
 回复
有个bing的官方API： xml版：http://cn.bing.com/HPImageArchive.aspx?idx=0&n=1 json版：http://cn.bing.com/HPImageArchive.aspx?format=js&idx=0&n=1 可以直接获取图片地址。。 以上来自知乎 https://www.zhihu.com/question/37582333
xpj_4901 2016-06-09
  • 打赏
  • 举报
 回复
我的是win7 64位，按照 http://bbs.csdn.net/topics/391959075 也添加了Microsoft VBScript Regular Expression 5.5 引用
xpj_4901 2016-06-09
  • 打赏
  • 举报
 回复
引用 11 楼 sysdzw 的回复:
[quote=引用 10 楼 xpj_4901 的回复:] [quote=引用 9 楼 sysdzw 的回复:] 上楼下载地址修改：http://download.csdn.net/detail/sysdzw/9543048
mse警报 大神们能出个js版的么？[/quote]放过就行了。。这都是代码源码的怕个啥，实在怕自己重新编译下好了 js怎么设置桌面啊，几乎不可能 。[/quote]
引用 11 楼 sysdzw 的回复:
[quote=引用 10 楼 xpj_4901 的回复:] [quote=引用 9 楼 sysdzw 的回复:] 上楼下载地址修改：http://download.csdn.net/detail/sysdzw/9543048
mse警报 大神们能出个js版的么？[/quote]放过就行了。。这都是代码源码的怕个啥，实在怕自己重新编译下好了 js怎么设置桌面啊，几乎不可能 。[/quote] 大神，卡住了 这句报错 Set reg = CreateObject("vbscript.regExp") 提示实时错误 -2147024770 8007007e 自动化错误
无·法 2016-06-09
  • 打赏
  • 举报
 回复
引用 10 楼 xpj_4901 的回复:
[quote=引用 9 楼 sysdzw 的回复:] 上楼下载地址修改：http://download.csdn.net/detail/sysdzw/9543048
mse警报 大神们能出个js版的么？[/quote]放过就行了。。这都是代码源码的怕个啥，实在怕自己重新编译下好了 js怎么设置桌面啊，几乎不可能 。
xpj_4901 2016-06-09
  • 打赏
  • 举报
 回复
引用 9 楼 sysdzw 的回复:
上楼下载地址修改：http://download.csdn.net/detail/sysdzw/9543048
mse警报 大神们能出个js版的么？
无·法 2016-06-08
  • 打赏
  • 举报
 回复
上楼下载地址修改：http://download.csdn.net/detail/sysdzw/9543048
无·法 2016-06-05
  • 打赏
  • 举报
 回复
引用 7 楼 mmsmusoft 的回复:
现在报错了，有劳更新更新，谢谢大神造福人类
把： reg.Pattern = "g_img={url:'(.*?)'" 修改为： reg.Pattern = "g_img={url:.*?(http:.*?.jpg)" 即可。原因：网页代码变了，导致正则匹配不到了。 下载地址；http://download.csdn.net/detail/sysdzw/9541739
mmsmusoft 2016-05-29
  • 打赏
  • 举报
 回复
现在报错了，有劳更新更新，谢谢大神造福人类
无·法 2014-12-04
  • 打赏
  • 举报
 回复
引用 5 楼 Sandrer 的回复:
有没有大海或者星空的?
想要尽情看可以装个spaceengineer，最高真实度模拟宇宙各个星球，尤其是极光特别绚丽。看我截图后上传的
http://bizhi.sogou.com/uhome/index/17343570?f=nav

Sandrer 2014-11-29
  • 打赏
  • 举报
 回复
有没有大海或者星空的?
一如既往哈 2014-11-28
  • 打赏
  • 举报
 回复
偶尔逛逛，便发现了好东东，收藏了，谢谢版主。
无·法 2014-11-28
  • 打赏
  • 举报
 回复

每天的壁纸还会自动保存在电脑里的。 今天的图不错
无·法 2014-11-27
  • 打赏
  • 举报
 回复
引用 1 楼 Sandrer 的回复:
话说做程序的谁会在意自己的屏幕 全部屏幕都是显示工作的内容，哪有时间去留意屏幕背景 晒晒我的桌面，让你们羡慕妒嫉下 2个24寸屏+1个17寸触摸屏
我以前做测试也是三个屏幕 17+ 19+23寸 话说经常换壁纸可以每天有点新鲜感么。每天都可以看到不同的美景。 早晨美景乐视 多么美好的一天开始了！
加载更多回复（1）
python批量下载必应每日壁纸
文章目录python批量下载必应每日壁纸一、图片来源选择二、python实现 python批量下载必应每日壁纸 必应搜索的每日背景壁纸都是高质量的图片，下载来当桌面壁纸再好不过了，微软官方也推出过bing缤纷桌面软件，实现桌面背景的每日更新。近期在学习python，于是想尝试批量下载必应搜索的每日背景图片。 一、图片来源选择 搜索一些技术博客，发现大家用的图片来源主要有两个： 个人网站https...
探索 Bing 背后的每日壁纸——`xBing`项目详解
探索 Bing 背后的每日壁纸——xBing项目详解 项目地址:https://gitcode.com/xCss/bing 项目简介 Bing 搜索引擎以其每日更新的精美壁纸闻名，这些壁纸涵盖了自然、艺术、科技等多个领域，为我们的电脑桌面带来了视觉享受。现在，通过xCss/bing 这个项目，你可以轻松获取这些壁纸，并将其用于你的网站、应用或者个人项目中。 技术分析 xBing 是一个使用 Pyt...
Qt之http通讯简单用法 /编写必应主页小爬虫，获取当日壁纸
摘要：本人希望能够每天更换桌面背景，又觉得常规手动步骤太过麻烦（从网上找图片->下载至本地->打开本地路径->右键设为壁纸），鉴于必应壁纸质量很高，索性写了一个程序自动实现其全部过程。（文末附本程序完整源代码的链接） 本文介绍了从网上爬取图片的实现，即Qt的http网络通讯的简单应用。后半部分调用本地系统API设置壁纸的过程，在其他文章另有介绍。
Python程序员：代码写的好，丝滑的壁纸少不了
嗨喽，大家好呀~这里是爱看美女的茜茜呐又到了学Python时刻~不知道大家的电脑桌面一般用的什么类型的壁纸？早上来上班，打开电脑，被漂亮的桌面壁纸所吸引，年底将近，这又是哪个地方的节日？才晓得，原来这是泰国第二大城市清迈的“天灯节”，把🏮送上天空是对神灵的尊敬，代表着摆脱厄运，祈求好运灯笼通常是由宣纸制成，把点燃的蜡烛固定在中心。火能产生足够的热量使灯笼变得很轻，可以飘向天空。有些人认为，如果你的灯笼在蜡烛燃尽之前消失在夜空中，那么你将在新的一年里获得好运。
Python写得好，壁纸无烦恼！
1、传入 resolution 参数可以指定壁纸图像的分辨率。
多媒体

809

社区成员

8,275

社区内容

发帖
与我相关
我的任务
社区描述
VB 多媒体
社区管理员
  • 多媒体
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章