809
社区成员
发帖
与我相关
我的任务
分享
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
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