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


原文发布于微信公众号 - VB小源码(vb_xym)

原文发表时间:2018-12-27

本文参与腾讯云自媒体分享计划,欢迎正在阅读的你也加入,一起分享。

发表于

我来说两句

0 条评论
登录 后参与评论

扫码关注云+社区

领取腾讯云代金券