form1.frm

用VB写的闯红灯自动抓拍系统 根据地方不同修改服务器地址。

    Dim i As Integer
    i = 0
    Me.Top = (Screen.Height - Me.Height) / 2 - 1000
    Me.Left = (Screen.Width - Me.Width) / 2
    Me.Show
    Ks.CursorLocation = adUseClient
    ccn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\db\id.mdb;Persist Security Info=False"
    Ks.Open "select * from mc", ccn, 1, 3
    Do While Not Ks.EOF
      mc(i) = Ks(0)
      Ip(i) = Ks(1)
      i = i + 1
      Ks.MoveNext
    Loop
    LKs = Ks.RecordCount
    Ks.Close
    Cn.CursorLocation = adUseClient
   Cn.Open "Driver={Microsoft Visual FoxPro Driver};SourceType=DBF;SourceDB=" & App.Path & "\PICDATA;" & "Exclusive=NO"
    k = 3 * 60 * 60
End Sub

Private Sub Form_Unload(Cancel As Integer)
   HTAgent1.CloseTrans
   ccn.Close
   Cn.Close
End Sub

Public Sub CsSj()
   Dim Cd As String
   Dim Fx As String
   Dim FL As String
   If List1.ListCount > 100 Then List1.Clear
   Open App.Path & "\cs.txt" For Input As #1
   Input #1, Cs(1)
   Input #1, Cs(2)
   Input #1, Cs(3)
   Close #1
   List1.AddItem "启动传输时间 " & Date & " " & Time
   If Not HTAgent1.InitTrans(Cs(2), Cs(1)) Then
        List1.AddItem "连接 失败"
   Else
        List1.AddItem "连接成功 "
   End If
   If HTAgent1.QuerySyncTime() = "" Then
       List1.AddItem "取服务器时间失败 "
   Else
       List1.AddItem "取服务器时间成功 " & HTAgent1.QuerySyncTime()
   End If
   
   FL = Dir(App.Path & "\PICDATA\*.dbf")
   Do While FL <> ""
        RS.CursorLocation = adUseClient
        RS.Open "select * from " & FL & " where not sended", Cn, 1, 3
        List1.AddItem "**************************************"
        List1.AddItem "传输" & RS.RecordCount & " 条记录"
        ProgressBar3.Max = RS.RecordCount + 1
        ProgressBar3.Value = 0
        List1.AddItem "传输开始..." & FL
        List1.AddItem "**************************************"
        Do While Not RS.EOF
           ProgressBar3.Value = ProgressBar3.Value + 1
           Label4.Caption = Int(ProgressBar3.Value * 10000 / ProgressBar3.Max) / 100 & "%"
           Label4.Refresh
           Cd = "2"
           If InStr(RS("ADDRESS"), "左") > 4 Then Cd = "1"
           If InStr(RS("ADDRESS"), "直") > 4 Then Cd = "2"
           If InStr(RS("ADDRESS"), "右") > 4 Then Cd = "3"
           
           If InStr(RS("ADDRESS"), "东->西") > 4 Then Fx = "E-W"
           If InStr(RS("ADDRESS"), "南->北") > 4 Then Fx = "S-N"
           If InStr(RS("ADDRESS"), "西->东") > 4 Then Fx = "W-E"
           If InStr(RS("ADDRESS"), "北->南") > 4 Then Fx = "N-S"
           fN(1) = App.Path & "\picdata\" & Mid(RS("filename"), 1, InStr(RS("filename"), ".") - 1) & "A.jpg"
           fN(2) = App.Path & "\picdata\" & Mid(RS("filename"), 1, InStr(RS("filename"), ".") - 1) & "B.jpg"
           fN(3) = "" 'App.Path & "\hl9000\" & Mid(Rs("filename"), 1, InStr(Rs("filename"), ".") - 1) & "C.jpg"
           fN(4) = "" 'App.Path & "\hl9000\" & Mid(Rs("filename"), 1, InStr(Rs("filename"), ".") - 1) & "D.jpg"
           If HTAgent1.WriteVehicleInfo(Cs(2), RS("bh"), "02", Fx, Cd, "", "", Replace(RS("DATE"), ".", "-") & " " & Format(RS("REDTIME")), "", "", 0, 0, "", "", 0, "", "", fN(1), fN(2), fN(3), fN(4), Cs(3), "1", "1") Then
               List1.ForeColor = RGB(0, 255, 0)
               List1.AddItem Trim(RS("filename")) & " 传输成功 " & Date & " " & Time
           Else
               List1.ForeColor = RGB(255, 0, 0)
               List1.AddItem Trim(RS("filename")) & " 传输失败 " & Date & " " & Time
           End If
           RS("SENDED") = True
           RS.MoveNext
        Loop
        Label4.Caption = "100%"
        RS.Close
        FL = Dir
   Loop
End Sub

Private Sub Timer1_Timer()
   If k = 0 Then
     k = 3 * 60 * 60
     Timer1.Enabled = False
     Xh
     CsSj
     Command3_Click
     Command2_Click
     Timer1.Enabled = True
   Else
     Label1.Caption = (k \ 60) \ 60 & "时" & (k \ 60) Mod 60 & "分" & k Mod 60 & "秒"
     k = k - 1
   End If
End Sub
Public Sub Xh()
  Dim i As Integer
  List2.Clear
  List2.AddItem "有 " & LKs & " 个路口机等待下载数据..."
  List2.Refresh
  ProgressBar2.Max = LKs
  ProgressBar2.Visible = True
  Command4.Enabled = False
  For i = 0 To LKs - 1
     Label2.Caption = Int((i * 10000) / LKs) / 100 & "%"
     Label2.Refresh
     ProgressBar2.Value = i
     XZ Ip(i)
     Zh mc(i)
  Next
  Label2.Caption = "100%"
  Label2.Refresh
  ProgressBar2.Value = LKs
 ' ProgressBar2.Visible = False
 Command4.Enabled = True
 Command3.Enabled = True
End Sub
Public Sub Zh(Dz As String)
   On Error Resume Next
   Dim rrs As New ADODB.Recordset
   Dim Fso As New FileSystemObject
   Dim Fle As String
   Dim id As Long
   Dim SJ As String
   Dim JSH As Long
  ' Cn.CursorLocation = adUseClient
  ' Cn.Open "Driver={Microsoft Visual FoxPro Driver};SourceType=DBF;SourceDB=" & App.Path & "\PICDATA;" & "Exclusive=NO"
   If Dir(App.Path & "\PICDATA\PA4" & Mid(Format(Date, "yyyymmdd"), 3) & ".dbf", 4) = "" Then
        Fso.CopyFile App.Path & "\DB\zl.dbf", App.Path & "\PICDATA\PA4" & Mid(Format(Date, "yyyymmdd"), 3) & ".dbf"
        List2.AddItem "创建 PA4" & Mid(Format(Date, "yyyymmdd"), 3) & ".dbf 成功"
   End If
   rrs.Open "select * from id", ccn, 1, 3
   If rrs(1) = Date Then
     id = rrs(0)
   Else
     id = 0
     rrs(1) = Date
     rrs.Update
   End If
   ProgressBar1.Max = WSum + 1
   ProgressBar1.Value = 0
   ProgressBar1.Visible = True
   JSH = 0
   RS.CursorLocation = adUseClient
   RS.Open "select * from " & "PA4" & Mid(Format(Date, "yyyymmdd"), 3), Cn, 1, 3
   Fle = Dir(App.Path & "\tmp\*a.jpg")
   Do While Fle <> ""
        ProgressBar1.Value = JSH
        JSH = JSH + 1
        id = id + 1
        SJ = TqSj(App.Path & "\tmp\" & Fle)
        RS.AddNew
        RS("BH") = id
        RS("TRIGTIME") = 0#
        RS("SENDED") = 0
        RS("PAIZHAO") = ""
        RS("RECTX1") = 0
        RS("RECTY1") = 0
        RS("RECTX2") = 0
        RS("RECTY2") = 0
        RS("date") = Mid(SJ, 1, 10)
        RS("redtime") = Mid(SJ, 30)
        RS("redlast") = 0
        RS("Taketime") = 0
        RS("address") = Dz
        RS("filename") = "A4" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & ".MPG"
        RS.Update
        List2.AddItem "信息写入成功"
        List2.Refresh
        Fso.CopyFile App.Path & "\tmp\" & Fle, App.Path & "\picdata\A4" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & "A.jpg"
        List2.AddItem "拷贝文件成功 " & Fle & "->" & "A4" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & "A.jpg"
        List2.Refresh
        Fso.CopyFile App.Path & "\tmp\" & Mid(Fle, 1, InStr(Fle, "a") - 1) & "b.jpg", App.Path & "\picdata\A4" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & "B.jpg"
        List2.AddItem "拷贝文件成功 " & Mid(Fle, 1, InStr(Fle, "a") - 1) & "b.jpg" & "->" & "A4" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & "B.jpg"
        List2.Refresh
        Kill App.Path & "\tmp\" & Fle
        List2.AddItem "删除文件成功 " & Fle
        List2.Refresh
        Kill App.Path & "\tmp\" & Mid(Fle, 1, InStr(Fle, "a") - 1) & "b.jpg"
        List2.AddItem "删除文件成功 " & Mid(Fle, 1, InStr(Fle, "a") - 1) & "b.jpg"
        List2.Refresh
        Fle = Dir
   Loop
   RS.Close
   rrs(0) = id
   rrs.Update
   rrs.Close
  ' ProgressBar1.Visible = False
   
End Sub
Public Function TqSj(Fle As String) As String
  On Error Resume Next
  Dim k(27) As Byte
  Dim i As Long, j As Long
  Dim SJ As String
  Open Fle For Binary As #1
  i = LOF(1)
  Get #1, i - 27, k
  SJ = 2000 + (Val(k(0) & k(1))) & "." & String$(2 - Len(Trim(Str(k(2) & k(3)))), "0") & Trim(Str(k(2) & k(3))) & "." & String$(2 - Len(Trim(Str(k(4) & k(5)))), "0") & Trim(Str(k(4) & k(5))) & String$(2 - Len(Trim(Str(k(6) & k(7)))), "0") & Trim(Str(k(6) & k(7))) & ":" & String$(2 - Len(Trim(Str(k(8) & k(9)))), "0") & Trim(Str(k(8) & k(9))) & ":" & String$(2 - Len(Trim(Str(k(10) & k(11)))), "0") & Trim(Str(k(10) & k(11)))
  
  SJ = SJ & "!" & 2000 + (Val(k(12) & k(13))) & "." & String$(2 - Len(Trim(Str(k(14) & k(15)))), "0") & Trim(Str(k(14) & k(15))) & "." & String$(2 - Len(Trim(Str(k(16) & k(17)))), "0") & Trim(Str(k(16) & k(17))) & String$(2 - Len(Trim(Str(k(18) & k(19)))), "0") & Trim(Str(k(18) & k(19))) & ":" & String$(2 - Len(Trim(Str(k(20) & k(21)))), "0") & Trim(Str(k(20) & k(21))) & ":" & String$(2 - Len(Trim(Str(k(22) & k(23)))), "0") & Trim(Str(k(22) & k(23)))
  Close 1
  TqSj = SJ
  'Image1.Picture = LoadPicture(App.Path & "\jpg\img00645a.jpg")
  'Image2.Picture = LoadPicture(App.Path & "\jpg\img00645b.jpg")
End Function
Private Sub XZ(Ip As String)
    On Error Resume Next
    Dim sNames() As String
    Dim bFiles() As Boolean
    Dim dtDateTimes() As String
    Dim lSizes() As Long
    Dim lNumLines As Long, lNumDetails As Long
    Dim i As Integer
    List2.AddItem " 开始连接，请稍侯..." & Ip
    List2.Refresh
    If FTP1.Connected = False Then
       FTP1.Disconnect
       FTP1.WildCard = "*.jpg"
       FTP1.Connect Ip, "root", ""
       FTP1.Cd "mnt"
       FTP1.Cd "imagefolder"
    End If
    If FTP1.Connected = False Then List2.AddItem " 连接失败..."
    If FTP1.List(sNames(), bFiles(), dtDateTimes(), lSizes()) > 0 Then
        If UBound(sNames()) > 0 Then
           lNumLines = UBound(sNames())
           ProgressBar1.Visible = True
           ProgressBar1.Max = lNumLines
           ProgressBar1.Value = 0
           List2.AddItem "文件总数:" & lNumLines - 1
           List2.Refresh
           WSum = lNumLines - 1
           For i = 1 To lNumLines
               Label3.Caption = i / lNumLines * 100 & "%"
               Label3.Refresh
               FTP1.WildCard = "*.jpg"
               FTP1.Connect Ip, "root", ""
               FTP1.Cd "mnt"
               FTP1.Cd "imagefolder"
               If bFiles(i) Then
                    ProgressBar1.Value = i
                    List2.AddItem " 开始下载 " & sNames(i)
                    List2.Refresh
                    If FTP1.GetFile(sNames(i), App.Path & "\tmp") <> ftpSuccess Then List2.AddItem "下载失败"
                    List2.Refresh
                    List2.AddItem " 开始删除 " & sNames(i)
                    List2.Refresh
                    If FTP1.Delete(sNames(i)) <> ftpSuccess Then List2.AddItem " 删除失败"
                    List2.Refresh
               End If
               FTP1.Disconnect
               DoEvents
            Next
           ' ProgressBar1.Visible = False
         End If
    End If
End Sub