很喜欢ONE一个每天推送的一幅画和一段文字，有时候经常看到图片后右键另存为，看到PC端只有网页版ONE，所以就用VB写了一个简单的可执行文件，功能保留了最基本的一幅图和一段文字，对于不喜欢看长篇文字的我来说，足矣。
思路
这是获取源码的网站：http://caodan.org/
可以看到我们要获取的内容：
获取网站的源码，可以看到：
现在要做的，分为下面几个步骤：
1、获取当前的期刊号，比如2015年2月10日是856刊。
2、获取网页图片的源地址：http://caodan20140611.qiniudn.com/wp-content/uploads/vol/856.jpg"
3、获取网页源代码，利用代码标签搜索得到标题、作者、内容。
4、构建框体，设计UI，构建程序应该用什么功能。
5、代码优化，封装打包成EXE。
有了思路，我们可以进行下一步。
首先我们要构建一个框体，用了2个主框架，Form1和Form2，16个Label，3个Textbox，3个Image和 Picturebox。
有了框架和UI，可以进行下一步啦~
获取刊期号：
Dim day, month, days
month = Format(Date, "mm")
day = Format(Date, "dd")
Select Case month
Case 2
days = day + 31
Case 3
days = day + 59
Case 4
days = day + 90
Case 5
days = day + 120
Case 6
days = day + 151
Case 7
days = day + 181
Case 8
days = day + 212
Case 9
days = day + 243
Case 10
days = day + 273
Case 11
days = day + 304
Case 12
days = day + 334
End Select
datee = 815 + days获取网络源码：
Function getHTTPPage(url) '获取网站源码
On Error Resume Next
Dim http
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", url, False
getHTTPPage = http.Send()
If http.ReadyState <> 4 Then
Debug.Print "无法连接服务器"
getHTTPPage = "无法连接服务器"
Exit Function
End If
getHTTPPage = BytesToBstr(http.responseBody, "GB2312")
Set http = Nothing
End Function
Function BytesToBstr(body, Cset) '转码
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.Open
objstream.Write body
objstream.position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function
获取特定字符的源码：
Function GetByDiv(ByVal code As String, ByVal divBegin As String, divEnd As String) '获取分隔符所夹的内容
Dim lgStart As Long
Dim lens As Long
Dim lgEnd As Long
lens = Len(divBegin)
lgStart = InStr(1, code, divBegin) + CLng(lens)
lgEnd = InStr(lgStart, code, divEnd)
GetByDiv = Mid(code, lgStart, lgEnd - lgStart)
End Function在这里，我们将2次获取一个内容，比如获取内容我们先获取：><p>那些可以轻而易举伤害我们的人，那些一再以痛楚和挫败试探我们的人，那些举起旗子引导我们走入迷途深林的人，那些在削弱我们的力量的人，那些让我们深深触动和粉碎自我的人，他们才是生命中最有力量的老师。by
安妮宝贝</p>
在获取> <之间的内容：那些可以轻而易举伤害我们的人，那些一再以痛楚和挫败试探我们的人，那些举起旗子引导我们走入迷途深林的人，那些在削弱我们的力量的人，那些让我们深深触动和粉碎自我的人，他们才是生命中最有力量的老师。by 安妮宝贝
获取作者，标题的方法类似。
有了网页源码，我们可以构建一个函数来获取图片和文字：
Function getimg(datee) '获取图片并显示
Dim name As String
name = "D:OnePhoto" + datee + ".jpg"
web = "http://caodan20140611.qiniudn.com/wp-content/uploads/vol/" + datee + ".jpg"
web2 = "http://caodan.org/" + datee + "-photo.html"
If Dir("D:OnePhoto", vbDirectory) = "" Then '判断文件夹是否存在
MkDir ("D:OnePhoto") '创建文件夹
End If
q = DownloadFile(web, name)
If q Then
'MsgBox "获取成功！", , "状态"
End If
Image1.Picture = LoadPicture(name)
temp = getHTTPPage(web2)
titel.Caption = GetByDiv(GetByDiv(temp, "entry-title", "/"), ">", "<") '获取标题
content.Caption = GetByDiv(GetByDiv(temp, "blockquote><p", "/"), ">", "<") '获取内容
author.Caption = GetByDiv(temp, "<br />", "<") '获取作者
End Function
我们想要移动这个窗口怎么办？
利用label，将label的属性backstyle=0即可，更改名称为：labFormTitle增加源码：
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _ ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function ReleaseCapture Lib "user32" () As Long Private Const WM_SYSCOMMAND = &H112 Private Const SC_MOVE = &HF010& Private Const HTCAPTIO = 2
Private Sub labFormTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture 'WM_SYS向窗体发送一个移动窗体命令
Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTIO, 0)
'SC_MOVE+ HTCAPTIO表示单击左键移动窗体
End Sub
将文字和图片在特定位置显示后，Form1就构建完成啦。
构建Form2，我们将要赋予Form2以下功能：
·批量下载图片
·转到某一天的内容
·浏览过去的内容
·回到今天
所以，我们赋予Form2下面的代码：
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const HTCAPTIO = 2
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_UPDATEINIFILE = &H1
Dim Wallpaper As String
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
Private Sub jump_Click()
Form1.state = 1
Form1.jump2 = jump1.Text
Unload Form2
Form1.Show
End Sub
Private Sub end_Click()
Unload Form2
Form1.Show
End Sub
Private Sub Form_Load()
min.BackColor = &H8000000F
max.BackColor = &H8000000F
jump.BackColor = &H8000000F
max.Text = Form1.datee
jump1.Text = Form1.datee
min.Text = Form1.datee - 1
End Sub
Private Sub labFormTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture 'WM_SYS向窗体发送一个移动窗体命令
Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTIO, 0)
'SC_MOVE+ HTCAPTIO表示单击左键移动窗体
End Sub
Private Sub load_Click()
Dim a As String
Dim b As String
a = min.Text
b = max.Text
If a > b Then
MsgBox "起始值大于终止值！", , "状态"
End If
Dim q As Boolean
Dim web As String
Dim name As String
Do
name = "D:OnePhoto" + a + ".jpg"
web = "http://caodan20140611.qiniudn.com/wp-content/uploads/vol/" + a + ".jpg"
If Dir("D:OnePhoto", vbDirectory) = "" Then '判断文件夹是否存在
MkDir ("D:OnePhoto") '创建文件夹
End If
q = DownloadFile(web, name)
If q Then
'MsgBox "获取成功！", , "状态"
End If
If a > b Then
MsgBox "下载完成！", , "状态"
Exit Do
End If
a = a + 1
Loop
End Sub
Private Sub open_Click()
If Dir("D:OnePhoto", vbDirectory) = "" Then '判断文件夹是否存在
MkDir ("D:OnePhoto") '创建文件夹
End If
Shell "explorer.exe ""D:OnePhoto""", vbNormalFocus '打开相应的文件夹
End Sub
Option Explicit
Public datee As String
Public last As String
Public state
Public jump2 As String
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_UPDATEINIFILE = &H1
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE = &HF010&
Private Const HTCAPTIO = 2
'定义变量区
Dim Wallpaper As String
Dim web As String
Dim web2 As String
Dim q As Boolean
Dim temp As String
'================
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
Function getHTTPPage(URL) '获取网站源码
On Error Resume Next
Dim http
Set http = CreateObject("MSXML2.XMLHTTP")
http.open "GET", URL, False
getHTTPPage = http.Send()
If http.ReadyState <> 4 Then
Debug.Print "无法连接服务器。"
getHTTPPage = "无法连接服务器。"
Exit Function
End If
getHTTPPage = BytesToBstr(http.responseBody, "UTF-8")
Set http = Nothing
End Function
Function BytesToBstr(body, Cset) '转码
Dim objstream
Set objstream = CreateObject("adodb.stream")
objstream.Type = 1
objstream.Mode = 3
objstream.open
objstream.Write body
objstream.position = 0
objstream.Type = 2
objstream.Charset = Cset
BytesToBstr = objstream.ReadText
objstream.Close
Set objstream = Nothing
End Function
Function GetByDiv(ByVal code As String, ByVal divBegin As String, divEnd As String) '获取分隔符所夹的内容
Dim lgStart As Long
Dim lens As Long
Dim lgEnd As Long
lens = Len(divBegin)
lgStart = InStr(1, code, divBegin) + CLng(lens)
lgEnd = InStr(lgStart, code, divEnd)
GetByDiv = Mid(code, lgStart, lgEnd - lgStart)
End Function
Private Sub Form_Load()
Dim day, month, days
month = Format(Date, "mm")
day = Format(Date, "dd")
Select Case month
Case 2
days = day + 31
Case 3
days = day + 59
Case 4
days = day + 90
Case 5
days = day + 120
Case 6
days = day + 151
Case 7
days = day + 181
Case 8
days = day + 212
Case 9
days = day + 243
Case 10
days = day + 273
Case 11
days = day + 304
Case 12
days = day + 334
End Select
datee = 815 + days
If state = 1 Then
getimg (jump2)
Else
getimg (datee)
End If
last = datee
End Sub
Private Sub Label1_Click()
End
End Sub
Private Sub labFormTitle_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ReleaseCapture 'WM_SYS向窗体发送一个移动窗体命令
Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_MOVE + HTCAPTIO, 0)
'SC_MOVE+ HTCAPTIO表示单击左键移动窗体
End Sub
Private Sub last1_Click()
last = last - 1
getimg (last)
End Sub
Private Sub setting_Click()
Form2.Show
Unload Form1
End Sub
Private Sub today_Click()
getimg (datee)
End Sub
Function getimg(datee) '获取图片并显示
Dim name As String
name = "D:OnePhoto" + datee + ".jpg"
web = "http://caodan20140611.qiniudn.com/wp-content/uploads/vol/" + datee + ".jpg"
web2 = "http://caodan.org/" + datee + "-photo.html"
If Dir("D:OnePhoto", vbDirectory) = "" Then '判断文件夹是否存在
MkDir ("D:OnePhoto") '创建文件夹
End If
q = DownloadFile(web, name)
If q Then
'MsgBox "获取成功！", , "状态"
End If
Image1.Picture = LoadPicture(name)
temp = getHTTPPage(web2)
titel.Caption = GetByDiv(GetByDiv(temp, "entry-title", "/"), ">", "<") '获取标题
content.Caption = GetByDiv(GetByDiv(temp, "blockquote><p", "/"), ">", "<") '获取内容
author.Caption = GetByDiv(temp, "<br />", "<") '获取作者
End Function
这样，ONE一个就构建完成~
项目截图：
设置&介绍：
登录麻鱼，了解ONE·一个·Mayuko 更多功能！点击访问 （手机端显示不正常，浏览器标识调成桌面即可）
@ Mayuko