Board logo

标题: [原创] 【分享】VBS实现车辆违章在线查询 [打印本页]

作者: batman    时间: 2011-6-19 20:48     标题: 【分享】VBS实现车辆违章在线查询

暂时只搞了个查询在上海市有违章纪录的,大家先测试吧。。。
  1. Dim Area, Types, Var, Cardqz, Type1, Carnumber, Fdjh
  2. Area = Array("京","沪","港","吉","鲁","冀","湘","青","苏","浙","粤","台","甘","川","黑","内蒙","新","津","渝","澳","辽","豫","鄂","晋","皖","赣","闽","琼","陕","云","贵","藏","宁","桂")
  3. Types = Array("01/大型汽车号牌","02/小型汽车号牌","06/外籍汽车号牌","07/两/三轮摩托车号牌","08/轻便摩托车号牌","16/教练汽车号牌")
  4. For i = 0 To UBound(Area)
  5.   j = j + 1
  6.   Var = Var & Right("   " & i + 1, 2) & " " & Left(Area(i) & string(10, " ") , 3)
  7.   If j = 3 Then Var = Var & vbCrLf : j = 0
  8. Next
  9. Do Until Cardqz <> ""
  10.   Cardqz = InputBox(Var, "请按序号选择车辆归属地")
  11. Loop
  12. Cardqz = Area(Int(Cardqz - 1)) : Var = ""
  13. For i = 0 To UBound(Types)
  14.   Var = Var & Right("   " & i + 1, 2) & " " & Left(Types(i) & string(10, " ") , 8) & vbCrLf
  15. Next
  16. Do Until Type1 <> ""
  17.   Type1 = InputBox(Var, "请按序号选择车辆的型号")
  18. Loop
  19. Type1 = Types(Int(Type1 - 1))
  20. Do Until Carnumber <> ""
  21.   Carnumber = InputBox("", "请准确输入车辆牌照")
  22. Loop
  23. Carnumber = Replace(UCase(Carnumber), Cardqz, "")
  24. Do Until Fdjh <> ""
  25.   Fdjh = InputBox("", "请准确输入车辆发动机号")
  26. Loop
  27. Fdjh = UCase(Fdjh)
  28. MsgBox INPUT(Cardqz, Type1, Carnumber, Fdjh)
  29. Function INPUT(Cardqz, Type1, Carnumber, Fdjh)
  30.   Dim XMLHTTP, STREAM, DOM, SHELL, Url, LoginInfo, Path, Str
  31.   LoginInfo = "action=dzjc_new.asp" _
  32.     & "&cardqz=" & escape(Cardqz) _
  33.     & "&carnumber=" & Carnumber _
  34.     & "&type1=" & escape(Type1) _
  35.     & "&fdjh=" & Fdjh _
  36.     & "&act=search" _
  37.     & "&submit=true"
  38.   Url = "http://www.shjtaq.com/zwfg/dzjc_new.asp"
  39.   Set XMLHTTP = CreateObject("MsXml2.XmlHttp")
  40.   XMLHTTP.open "POST", Url, False
  41.   XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  42.   XMLHTTP.send(LoginInfo)
  43.   Do Until XMLHTTP.readyState = 4 : WScript.Sleep 200 : Loop
  44.   WScript.Sleep 1000
  45.   Set STREAM = CreateObject("Adodb.Stream")
  46.   STREAM.Type = 1
  47.   STREAM.Mode = 3
  48.   STREAM.Open()
  49.   STREAM.Write XMLHTTP.responseBody
  50.   STREAM.SaveToFile "temp.html", 2
  51.   XMLHTTP.abort
  52.   Set XMLHTTP = Nothing
  53.   STREAM.Close
  54.   Set SHELL = CreateObject("Wscript.Shell")
  55.   Path = SHELL.CurrentDirectory & "\"
  56.   Set STREAM = Nothing
  57.   Set DOM = GetObject(Path & "temp.html", "HtmlFile")
  58.   Do Until DOM.readyState = "complete" : WScript.Sleep 200 : Loop
  59.   For Each Str In DOM.GetElementsByTagName("font")
  60.     If InStr(Str.innertext, "您查询的") Then INPUT = Replace(Str.innertext, "本市", "上海市")
  61.   Next
  62.   Set DOM = Nothing
  63.   CreateObject("Scripting.FileSystemObject").DeleteFile "temp.html"
  64. End Function
复制代码

作者: batman    时间: 2011-6-19 21:12

接一个简洁模式的:
  1. MsgBox INPUT("沪", "02/小型汽车号牌", "CU1234", "12346")
  2. Function INPUT(Cardqz, Type1, Carnumber, Fdjh)
  3.   Dim XMLHTTP, STREAM, DOM, SHELL, Url, LoginInfo, Path, Str
  4.   LoginInfo = "action=dzjc_new.asp" _
  5.     & "&cardqz=" & escape(Cardqz) _
  6.     & "&carnumber=" & Carnumber _
  7.     & "&type1=" & escape(Type1) _
  8.     & "&fdjh=" & Fdjh _
  9.     & "&act=search" _
  10.     & "&submit=true"
  11.   Url = "http://www.shjtaq.com/zwfg/dzjc_new.asp"
  12.   Set XMLHTTP = CreateObject("MsXml2.XmlHttp")
  13.   XMLHTTP.open "POST", Url, False
  14.   XMLHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  15.   XMLHTTP.send(LoginInfo)
  16.   Do Until XMLHTTP.readyState = 4 : WScript.Sleep 200 : Loop
  17.   WScript.Sleep 1000
  18.   Set STREAM = CreateObject("Adodb.Stream")
  19.   STREAM.Type = 1
  20.   STREAM.Mode = 3
  21.   STREAM.Open()
  22.   STREAM.Write XMLHTTP.responseBody
  23.   STREAM.SaveToFile "temp.html", 2
  24.   XMLHTTP.abort
  25.   Set XMLHTTP = Nothing
  26.   STREAM.Close
  27.   Set SHELL = CreateObject("Wscript.Shell")
  28.   Path = SHELL.CurrentDirectory & "\"
  29.   Set STREAM = Nothing
  30.   Set DOM = GetObject(Path & "temp.html", "HtmlFile")
  31.   Do Until DOM.readyState = "complete" : WScript.Sleep 200 : Loop
  32.   For Each Str In DOM.GetElementsByTagName("font")
  33.     If InStr(Str.innertext, "您查询的") Then INPUT = Replace(Str.innertext, "本市", "上海市")
  34.   Next
  35.   Set DOM = Nothing
  36.   CreateObject("Scripting.FileSystemObject").DeleteFile "temp.html"
  37. End Function
复制代码

作者: Demon    时间: 2011-6-23 12:17

冷冷清清
作者: batman    时间: 2011-6-23 15:46

本帖最后由 batman 于 2011-6-23 15:47 编辑

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

我在我冷清着,我冷清故我在。。。




欢迎光临 批处理之家 (http://www.bathome.net/) Powered by Discuz! 7.2