VBA 12306火车票查询系统V1.0
12306火车票查询系统用于查询车票车次等
窗体代码:
Private Sub bt_ok_Click()
Call sj
End Sub
Private Sub date_time_Change()
Call sj
End Sub
Private Sub UserForm_Initialize()
date_time.Value = Date '----初始化日期控件
End Sub
Sub sj()
If date_time.Value < Date Then
MsgBox "不允许搜索之前的车次!", vbExclamation, "VB小源码"
Exit Sub
End If
With Worksheets("车票信息").Range("j2")
.NumberFormatLocal = "@" '-----设置单元格格式为文本
.Value = Replace(date_time.Value, "/", "-") '----获得日期数据
End With
Cancel = False
DoEvents
Unload frm_date '----关闭窗体
End Sub
模块代码:
''------QQ群:344402874
''------微信公众号:VB小源码
''-----作者;巴西_prince
Dim jsn As New cls_getjson
Sub clear()
Worksheets("车票信息").Range("a4:aa5000").ClearContents '-----清空数据
End Sub
Sub 解析json()
' Application.ScreenUpdating = False
Dim str As String
Dim i As Integer
Call clear
str = jsn.getjson(Worksheets("车票信息").Range("J2").Value, jsn.网页码(Worksheets("车票信息").Range("d2").Value), jsn.网页码(Worksheets("车票信息").Range("g2").Value)) '----url拼接
Dim msc As New MSScriptControl.ScriptControl '---定义脚本
msc.Language = "JavaScript" '-----脚本语言
msc.AddCode ("var query = " & str) '-----用数据填充脚本
i = 4
Application.Calculation = xlCalculationManual '-----关闭自动重算
If CallByName(CallByName(CallByName(msc.CodeObject, "query", VbGet), "data", VbGet), "result", VbGet) = "" Then MsgBox "暂无车次信息!", vbInformation, "VB小源码"
For Each TMP In CallByName(CallByName(CallByName(msc.CodeObject, "query", VbGet), "data", VbGet), "result", VbGet) '---循环json的result记录集 数据
With Worksheets("车票信息")
.Range("a" & i).Value = Split(TMP, "|")(3) '----车次
.Range("b" & i).Value = jsn.站名(Split(TMP, "|")(4)) '-----始发站
.Range("c" & i).Value = jsn.站名(Split(TMP, "|")(5)) '-----终点站
.Range("d" & i).Value = jsn.站名(Split(TMP, "|")(6)) '-----出发站
.Range("e" & i).Value = jsn.站名(Split(TMP, "|")(7)) '-----到达站
.Range("f" & i).Value = Split(TMP, "|")(8) '----出发时间
.Range("g" & i).Value = Split(TMP, "|")(9) '----到达时间
.Range("h" & i).Value = Split(TMP, "|")(10) '----历时
.Range("i" & i).Value = Split(TMP, "|")(32) '---特等座/商务座
.Range("j" & i).Value = Split(TMP, "|")(31) '---一等座
.Range("k" & i).Value = Split(TMP, "|")(30) '---二等座
.Range("l" & i).Value = Split(TMP, "|")(21) '---高级软卧
.Range("m" & i).Value = Split(TMP, "|")(23) '---软卧
.Range("N" & i).Value = Split(TMP, "|")(33) '---动卧
.Range("O" & i).Value = Split(TMP, "|")(28) '---硬卧
.Range("P" & i).Value = Split(TMP, "|")(24) '---软座
.Range("Q" & i).Value = Split(TMP, "|")(29) '---硬座
.Range("R" & i).Value = Split(TMP, "|")(26) '---无座
.Range("t" & i).Value = Split(TMP, "|")(1) '---备注
End With
i = i + 1
Next
Application.Calculation = xlCalculationAutomatic '----开启自动重算
' Application.ScreenUpdating = True
End Sub
类模块代码:
'//获取12306车票JSON 数据
Function getjson(ByVal 时间 As String, ByVal 出发站 As String, ByVal 到达站 As String) As String
Dim str As String
With CreateObject("MSXML2.XMLHTTP") '---创建http对象
'----采用 get模式打开12306网址
.Open "GET", "https://kyfw.12306.cn/otn/leftTicket/queryA?leftTicketDTO.train_date=" & 时间 & "&leftTicketDTO.from_station=" & 出发站 & "&leftTicketDTO.to_station=" & 到达站 & "&purpose_codes=ADULT", False
.send '-----发送数据
str = .responseText '-----返回数据
End With
getjson = str
End Function
'//返回站点数据
Function dta()
Dim H As Integer
Dim arr()
H = Worksheets("站点数据").Range("d65536").End(xlUp).Row '------获得有效行数
arr = Worksheets("站点数据").Range("a2:g" & H).Value '----数据填充数组
dta = arr
End Function
'// 返回网页搜索码
Function 网页码(ByVal 城市名 As String) As String
网页码 = sqlstr("Select 网页检索码 FROM [站点数据$] Where 站点名称 = '" & 城市名 & "'")
End Function
'//返回站点名
Function 站名(ByVal 网页码 As String) As String
站名 = sqlstr("Select 站点名称 FROM [站点数据$] Where 网页检索码 = '" & 网页码 & "'")
End Function
'//连接Excel数据库
Function sqlstr(ByVal sql As String) As String
Dim cnn As ADODB.Connection '-----定义ADO连接
Dim rs As ADODB.Recordset '-----定义ADO记录集
Dim strSql As String
On Error Resume Next '---出错继续执行
Set cnn = CreateObject("ADODB.Connection") '----------创建ADO连接对象
Set rs = CreateObject("ADODB.Recordset") '----------创建ADO记录集对象
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & ThisWorkbook.FullName '---连接Excel数据库
strSql = sql '----sql查询语句
rs.Open strSql, cnn, adOpenStatic '------返回sql查询结果
sqlstr = rs(0) '----获取第一个记录集数据
rs.Close '----关闭数据库记录集
cnn.Close '----关闭数据库连接
Set rs = Nothing '---置空记录集
Set cnn = Nothing '----置空连接
End Function