form1.frm

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

             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"
                Fx = ""
                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 Option1.Value Then
                     If HTAgent1.WriteVehicleInfo(Sz(i, 3), Trim(RS("bh")), "02", Fx, Cd, "", "", Replace(RS("DATE"), ".", "-") & " " & Format(RS("REDTIME")), RS("redl"), "50", 0, 0, "1302", "", 0, "", "", fN(1), fN(2), fN(3), fN(4), Sz(i, 5), "1", "0") Then
                         List1.ForeColor = RGB(0, 255, 0)
                         List1.AddItem Trim(RS("filename")) & " 传输成功 " & Date & " " & Time
                         RS("SENDED") = True
                         Cgs = Cgs + 1
                     Else
                         List1.ForeColor = RGB(255, 0, 0)
                         List1.AddItem Trim(RS("filename")) & " 传输失败 " & Date & " " & Time
                         Sbs = Sbs + 1
                     End If
                Else
                     If HTAgent1.SyncWriteVehicleInfo(Sz(i, 3), RS("bh"), "02", Fx, Cd, "", "", Replace(RS("DATE"), ".", "-") & " " & Format(RS("REDTIME")), RS("redl"), "50", 0, 0, "1302", "", 0, "", "", fN(1), fN(2), fN(3), fN(4), Sz(i, 5), "1", "0") Then
                         List1.ForeColor = RGB(0, 255, 0)
                         List1.AddItem Trim(RS("filename")) & " 传输成功 " & Date & " " & Time
                         RS("SENDED") = True
                          Cgs = Cgs + 1
                     Else
                         List1.ForeColor = RGB(255, 0, 0)
                         List1.AddItem Trim(RS("filename")) & " 传输失败 " & Date & " " & Time
                         Sbs = Sbs + 1
                     End If
                End If
                
                RS.MoveNext
                List1.Refresh
                DoEvents
             Loop
             ProgressBar3.Value = ProgressBar3.Max
             Label4.Caption = "100%"
             RS.Close
             Set RS = Nothing
             FL = Dir
        Loop
        HTAgent1.CloseTrans
   Next
   List1.AddItem " 成功传输 " & Cgs & "条记录"
   List1.AddItem " 传输失败 " & Sbs & "条记录"
   List1.AddItem " 传输完成 " & Date & " " & Time
End Sub

Private Sub Timer1_Timer()
   Dim i As Integer
   Dim Wd As String
   Dim Wl As String
   Dim Cl As String
   Cl = ""
   If Val(Mid(Format(Time, "hh:nn:ss"), 4, 2)) Mod 26 = 25 And Val(Mid(Format(Time, "hh:nn:ss"), 7, 2)) = "00" Then
     k = 25 * 60
     Timer1.Enabled = False
     Xh
     CsSj
     SjSc
     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
   If Val(Mid(Format(Time, "hh:nn:ss"), 4, 2)) Mod 23 = 20 And Val(Mid(Format(Time, "hh:nn:ss"), 7, 2)) = "00" Then
       Timer1.Enabled = False
       Xh
       Command3_Click
       Timer1.Enabled = True
   End If
   If Val(Mid(Format(Time, "hh:nn:ss"), 4, 2)) Mod 15 = 0 And Val(Mid(Format(Time, "hh:nn:ss"), 7, 2)) = "00" Then
        List1.Clear
        Timer1.Enabled = False
        HTAgent1.CloseTrans
        For i = 1 To LKs
             List1.AddItem "启动传输时间 " & Date & " " & Time
             If Not HTAgent1.InitTrans(Sz(i, 3), Sz(i, 4)) Then
                  List1.AddItem "连接 失败"
                  Timer1.Enabled = True
                  Exit Sub
             Else
                  List1.AddItem "连接成功 "
             End If
             If HTAgent1.QuerySyncTime() = "" Then
                 List1.AddItem "取服务器时间失败 "
             Else
                 List1.AddItem "取服务器时间成功 " & HTAgent1.QuerySyncTime()
             End If
             List1.AddItem "传输设备状态..... "
             Randomize (Timer)
            
                  Wd = Trim(Str(Int(Rnd * 20) + 20))
                  FTP1.Disconnect
                  If FTP1.Connected = False Then
                     FTP1.Disconnect
                     FTP1.WildCard = "*.jpg"
                     FTP1.Connect Sz(i, 2), "root", ""
                     FTP1.Cd "mnt"
                     FTP1.Cd "imagefolder"
                   End If
                   If FTP1.Connected = False Then
                      List1.AddItem "设备 " & Sz(i, 2) & " 工作异常"
                      Cl = "0"
                      Wl = "1"
                      If HTAgent1.WriteDeviceStatus(Sz(i, 3), Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss"), "11111111", "1", "1", "1", Wl, "1", "1", "0") = True Then
                         List1.AddItem "写设备状态成功"
                      Else
                         List1.AddItem "写设备状态失败"
                      End If
                      If HTAgent1.WriteFlux(Sz(i, 3), "1", TCS, Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss"), Cl) = True Then
                         List1.AddItem "写车流量成功" & " " & TCS & "->" & Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss")
                      Else
                         List1.AddItem "写车流量失败"
                     End If
                   Else
                      List1.AddItem "设备 " & Sz(i, 2) & " 工作正常"
                      Wl = "0"
                      Cl = TjCl
                      If HTAgent1.WriteDeviceStatus(Sz(i, 3), Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss"), "00000000", "0", "0", "0", Wl, "0", "0", Wd) = True Then
                         List1.AddItem "写设备状态成功"
                      Else
                         List1.AddItem "写设备状态失败"
                      End If
                      If HTAgent1.WriteFlux(Sz(i, 3), "1", TCS, Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss"), Cl) = True Then
                         List1.AddItem "写车流量成功" & " " & TCS & "->" & Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss")
                      Else
                         List1.AddItem "写车流量失败"
                     End If
                   End If
                   
                   HTAgent1.CloseTrans
        Next
       TCS = Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss")
       Command2_Click
       Timer1.Enabled = True
  End If
  Timer1.Enabled = True
End Sub
Public Sub Xh()
  Dim i As Integer
  Timer1.Enabled = False
  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 Trim(Sz(i + 1, 2))
     Zh Trim(Sz(i + 1, 1))
  Next
  Label2.Caption = "100%"
  Label2.Refresh
  ProgressBar2.Value = LKs
 ' ProgressBar2.Visible = False
 Command4.Enabled = True
 Command3.Enabled = True
 Timer1.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, 20, 10)
        RS("redtime") = Mid(SJ, 30)
        RS("redl") = Replace(Mid(SJ, 1, 10), ".", "-") & " " & Mid(SJ, 11, 8)
        RS("redlast") = 0
        RS("Taketime") = 0
        RS("address") = Dz
        RS("filename") = "CG" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & ".MPG"
        If Mid(RS("date"), 1, 4) <> Format(Date, "yyyy") Then RS("SENDED") = 1
        RS.Update
        List2.AddItem "信息写入成功"
        List2.Refresh
        Fso.CopyFile App.Path & "\tmp\" & Fle, App.Path & "\picdata\CG" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & "A.jpg"
        List2.AddItem "拷贝文件成功 " & Fle & "->" & "CG" & 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\CG" & Format(Date, "yymmdd") & String$(4 - Len(Trim(Str(id))), "0") & id & "B.jpg"
        List2.AddItem "拷贝文件成功 " & Mid(Fle, 1, InStr(Fle, "a") - 1) & "b.jpg" & "->" & "CG" & 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
   List2.AddItem "信息写入完成"
  ' 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 Format(Date, "yyyy-mm-dd") & "  " & Format(Time, "hh:nn:ss")
    List2.AddItem " 开始连接，请稍侯..." & Ip
    List2.Refresh
    FTP1.Disconnect
    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 And (UBound(sNames()) Mod 2 <> 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 = Round(i / lNumLines * 100, 2) & "%"
               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
             FTP1.Delete "*.*"
           ' ProgressBar1.Visible = False
         End If
    End If
End Sub
Private Sub SjSc()
   On Error Resume Next
   Dim Fle As String
   Dim YD As String
   YD = Format(Date, "yyyymmdd")
   Fle = Dir(App.Path & "\picdata\*.dbf")
   List1.AddItem "正在清除数据过时文件..."
   Do While Fle <> ""
      If (Val(Mid(YD, 3, 2)) - Val(Mid(Fle, 4, 2))) * 12 * 30 + (Val(Mid(YD, 5, 2)) - Val(Mid(Fle, 6, 2))) * 30 + (Val(Mid(YD, 7, 2)) - Val(Mid(Fle, 8, 2))) > 60 Then
           RS.CursorLocation = adUseClient
           RS.Open "select * from " & Fle, Cn, 1, 3
           Do While Not RS.EOF
               Kill App.Path & "\picdata\" & Mid(RS("filename"), 1, InStr(RS("filename"), ".") - 1) & "A.jpg"
               List1.AddItem "清除" & App.Path & "\picdata\" & Mid(RS("filename"), 1, InStr(RS("filename"), ".") - 1) & "A.jpg"
               Kill App.Path & "\picdata\" & Mid(RS("filename"), 1, InStr(RS("filename"), ".") - 1) & "B.jpg"
               List1.AddItem "清除" & App.Path & "\picdata\" & Mid(RS("filename"), 1, InStr(RS("filename"), ".") - 1) & "B.jpg"
               List1.Refresh
               RS.MoveNext
           Loop
           RS.Close
           Set RS = Nothing
           Cn.Close
           Set Cn = Nothing
           Kill App.Path & "\picdata\" & Fle
           List1.AddItem "清除" & App.Path & "\picdata\" & Fle
           Cn.ConnectionString = "Driver={Microsoft Visual FoxPro Driver};SourceType=DBF;SourceDB=" & App.Path & "\PICDATA;" & "Exclusive=NO"
           Cn.Open
      End If
      Fle = Dir
  Loop
  
   YD = Format(Date, "yyyymmdd")
   Fle = Dir(App.Path & "\log\*.log")
   List1.AddItem "正在清除日志过时文件..."
   Do While Fle <> ""
      If (Val(Mid(YD, 3, 2)) - Val(Mid(Fle, 5, 2))) * 12 * 30 + (Val(Mid(YD, 5, 2)) - Val(Mid(Fle, 7, 2))) * 30 + (Val(Mid(YD, 7, 2)) - Val(Mid(Fle, 9, 2))) > 30 Then
               Kill App.Path & "\log\" & Fle
               List1.AddItem "清除" & App.Path & "\log\" & Fle
     End If
      Fle = Dir
  Loop
  List1.AddItem "清除完毕"
End Sub
Public Function TjCl() As String
    Dim Cl As String
    Dim TJS As String
    TJS = Format(Date, "yyyy-mm-dd") & " " & Format(Time, "hh:nn:ss")
    If ("06:00:00" < TJS And TJS < "08:00:00") Or ("11:20:00" < TJS And TJS < "12:300:00") Or ("13:20:00" < TJS And TJS < "14:20:00") Or ("16:30:00" < TJS And TJS < "18:10:00") Then
       Cl = Int(Rnd * 20) + 12
    Else
       Cl = Int(Rnd * 16)
    End If
    TjCl = Cl
   
End Function