[原创] 【分享】VBS实现车辆违章在线查询

batman

暂时只搞了个查询在上海市有违章纪录的，大家先测试吧。。。

Dim Area, Types, Var, Cardqz, Type1, Carnumber, Fdjh
Area = Array("京","沪","港","吉","鲁","冀","湘","青","苏","浙","粤","台","甘","川","黑","内蒙","新","津","渝","澳","辽","豫","鄂","晋","皖","赣","闽","琼","陕","云","贵","藏","宁","桂")
Types = Array("01/大型汽车号牌","02/小型汽车号牌","06/外籍汽车号牌","07/两/三轮摩托车号牌","08/轻便摩托车号牌","16/教练汽车号牌")
For i = 0 To UBound(Area)
  j = j + 1
  Var = Var & Right("   " & i + 1, 2) & "　" & Left(Area(i) & string(10, "　") , 3)
  If j = 3 Then Var = Var & vbCrLf : j = 0
Next
Do Until Cardqz <> ""
  Cardqz = InputBox(Var, "请按序号选择车辆归属地")
Loop
Cardqz = Area(Int(Cardqz - 1)) : Var = ""
For i = 0 To UBound(Types)
  Var = Var & Right("   " & i + 1, 2) & "　" & Left(Types(i) & string(10, "　") , 8) & vbCrLf
Next
Do Until Type1 <> ""
  Type1 = InputBox(Var, "请按序号选择车辆的型号")
Loop
Type1 = Types(Int(Type1 - 1))
Do Until Carnumber <> ""
  Carnumber = InputBox("", "请准确输入车辆牌照")
Loop
Carnumber = Replace(UCase(Carnumber), Cardqz, "")
Do Until Fdjh <> ""
  Fdjh = InputBox("", "请准确输入车辆发动机号")
Loop
Fdjh = UCase(Fdjh)
MsgBox INPUT(Cardqz, Type1, Carnumber, Fdjh)

Function INPUT(Cardqz, Type1, Carnumber, Fdjh)
  Dim XMLHTTP, STREAM, DOM, SHELL, Url, LoginInfo, Path, Str
  LoginInfo = "action=dzjc_new.asp" _
    & "&cardqz=" & escape(Cardqz) _
    & "&carnumber=" & Carnumber _
    & "&type1=" & escape(Type1) _
    & "&fdjh=" & Fdjh _
    & "&act=search" _
    & "&submit=true"
  Url = "http://www.shjtaq.com/zwfg/dzjc_new.asp"
  Set XMLHTTP = CreateObject("MsXml2.XmlHttp")
  XMLHTTP.open "POST", Url, False
  XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  XMLHTTP.send(LoginInfo)
  Do Until XMLHTTP.readyState = 4 : WScript.Sleep 200 : Loop
  WScript.Sleep 1000
  Set STREAM = CreateObject("Adodb.Stream")
  STREAM.Type = 1
  STREAM.Mode = 3
  STREAM.Open()
  STREAM.Write XMLHTTP.responseBody
  STREAM.SaveToFile "temp.html", 2
  XMLHTTP.abort
  Set XMLHTTP = Nothing
  STREAM.Close
  Set SHELL = CreateObject("Wscript.Shell")
  Path = SHELL.CurrentDirectory & "\"
  Set STREAM = Nothing
  Set DOM = GetObject(Path & "temp.html", "HtmlFile")
  Do Until DOM.readyState = "complete" : WScript.Sleep 200 : Loop
  For Each Str In DOM.GetElementsByTagName("font")
    If InStr(Str.innertext, "您查询的") Then INPUT = Replace(Str.innertext, "本市", "上海市")
  Next
  Set DOM = Nothing
  CreateObject("Scripting.FileSystemObject").DeleteFile "temp.html"
End Function
复制代码

batman

3# Demon
是谁说的来着：冷清也是一种生活姿态。。。

我在我冷清着，我冷清故我在。。。

Demon

冷冷清清

batman

接一个简洁模式的：

MsgBox INPUT("沪", "02/小型汽车号牌", "CU1234", "12346")

Function INPUT(Cardqz, Type1, Carnumber, Fdjh)
  Dim XMLHTTP, STREAM, DOM, SHELL, Url, LoginInfo, Path, Str
  LoginInfo = "action=dzjc_new.asp" _
    & "&cardqz=" & escape(Cardqz) _
    & "&carnumber=" & Carnumber _
    & "&type1=" & escape(Type1) _
    & "&fdjh=" & Fdjh _
    & "&act=search" _
    & "&submit=true"
  Url = "http://www.shjtaq.com/zwfg/dzjc_new.asp"
  Set XMLHTTP = CreateObject("MsXml2.XmlHttp")
  XMLHTTP.open "POST", Url, False
  XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  XMLHTTP.send(LoginInfo)
  Do Until XMLHTTP.readyState = 4 : WScript.Sleep 200 : Loop
  WScript.Sleep 1000
  Set STREAM = CreateObject("Adodb.Stream")
  STREAM.Type = 1
  STREAM.Mode = 3
  STREAM.Open()
  STREAM.Write XMLHTTP.responseBody
  STREAM.SaveToFile "temp.html", 2
  XMLHTTP.abort
  Set XMLHTTP = Nothing
  STREAM.Close
  Set SHELL = CreateObject("Wscript.Shell")
  Path = SHELL.CurrentDirectory & "\"
  Set STREAM = Nothing
  Set DOM = GetObject(Path & "temp.html", "HtmlFile")
  Do Until DOM.readyState = "complete" : WScript.Sleep 200 : Loop
  For Each Str In DOM.GetElementsByTagName("font")
    If InStr(Str.innertext, "您查询的") Then INPUT = Replace(Str.innertext, "本市", "上海市")
  Next
  Set DOM = Nothing
  CreateObject("Scripting.FileSystemObject").DeleteFile "temp.html"
End Function
复制代码