frmcapture.frm

基于VC++串口编程。经过好长时间的寻找

VERSION 5.00
Object = "{648A5603-2C6E-101B-82B6-000000000014}#1.1#0"; "MSCOMM32.OCX"
Begin VB.Form frmCapture 
   Caption         =   "电子警察拍照系统"
   ClientHeight    =   6600
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7455
   Icon            =   "frmCapture.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   6600
   ScaleWidth      =   7455
   StartUpPosition =   2  '屏幕中心
   WindowState     =   2  'Maximized
   Begin VB.PictureBox picCheck 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   912
      Left            =   3696
      ScaleHeight     =   59
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   88
      TabIndex        =   5
      Top             =   4152
      Visible         =   0   'False
      Width           =   1356
   End
   Begin VB.ListBox lstRecText 
      Height          =   1140
      Left            =   204
      TabIndex        =   4
      Top             =   5244
      Visible         =   0   'False
      Width           =   3192
   End
   Begin VB.ListBox lstFile 
      Height          =   780
      Left            =   252
      TabIndex        =   3
      Top             =   5820
      Visible         =   0   'False
      Width           =   3492
   End
   Begin VB.TextBox Text1 
      Height          =   1344
      Left            =   5328
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      TabIndex        =   2
      Top             =   3960
      Width           =   3216
   End
   Begin VB.Timer timCapture1 
      Enabled         =   0   'False
      Interval        =   40
      Left            =   6252
      Top             =   3672
   End
   Begin VB.PictureBox Image1 
      BackColor       =   &H00C0C0C0&
      Height          =   756
      Left            =   3708
      ScaleHeight     =   690
      ScaleWidth      =   1440
      TabIndex        =   1
      Top             =   480
      Width           =   1500
   End
   Begin VB.Timer timCapture2 
      Enabled         =   0   'False
      Interval        =   40
      Left            =   6732
      Top             =   3672
   End
   Begin MSCommLib.MSComm MSComm1 
      Left            =   1044
      Top             =   600
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   393216
      DTREnable       =   -1  'True
      Handshaking     =   2
      InBufferSize    =   2048
      NullDiscard     =   -1  'True
      OutBufferSize   =   2048
      RThreshold      =   1
      InputMode       =   1
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   510
      Left            =   4305
      TabIndex        =   0
      Top             =   5700
      Width           =   2370
   End
End
Attribute VB_Name = "frmCapture"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'图像卡工作变量
Dim HCG200 As Long
Dim Throw As Long

'记录视频工作状态
Dim bCh_OK(1 To 2) As Boolean
Dim nPostNo As Integer              '路口编号
Dim nDriveStyle As Integer          '行车方式
Dim nCurVideoChannel As Integer     '当前视频
Dim sDirection(1 To 2) As String    '行车方向，1对应1-3IO口编号;2对应4-6IO口编号
Dim nChkVideoMax As Integer         '检查视频源的时间间隔，分钟级

Dim SednArr(1 To g_SENDDATALENGTH) As Byte    '定义字节型数组
Dim bConnected As Boolean    '当前是否处于连接状态
Dim myDB As Database
Dim chRs As Recordset
Dim nNewRecID  As Long
Dim dLastDelDay As Date     '上次删除无用文件的日期

Private Sub Form_Load()
'将工作路径设置在程序所在路径
    ChDir App.Path
    bCh_OK(1) = True
    bCh_OK(2) = True
    
'初始化通讯端口
    If InitComm = False Then
        MsgBox "通讯端口初始化错误！", vbCritical
        End
    End If
'初始化抓拍设置
    If InitCaptureSet = False Then
        MsgBox "抓拍设置初始化错误！", vbCritical
        End
    End If
    
'初始化数据库，加载待传记录信息
    Call InitMDB
    
    Me.Show
    DoEvents
'初始化图像卡
    If InitCaptureCard = False Then
        MsgBox "图像卡初始化错误！", vbCritical
        End
    End If
        
    If nDriveStyle = 1 Then     '十字
        timCapture1.Enabled = True
        timCapture2.Enabled = False
    Else    '一字
        timCapture1.Enabled = False
        timCapture2.Enabled = True
    End If
End Sub

Private Sub Form_Resize()
    Image1.left = Me.ScaleWidth - (g_SCREEN_W + 5) * Screen.TwipsPerPixelX
    Image1.Top = 5 * Screen.TwipsPerPixelY
    Image1.Width = g_SCREEN_W * Screen.TwipsPerPixelX
    Image1.Height = g_SCREEN_H * Screen.TwipsPerPixelY
    
    Text1.Top = Image1.Top + Image1.Height + 100
    Text1.left = Image1.left
End Sub

Private Sub Form_Unload(Cancel As Integer)

'关闭通讯端口
    Call CloseComm
'关闭图像卡
    Call CloseCaptureCard
'关闭数据库
    Call CloseMDB
End Sub

'针对十字行车情况，路灯为1对应1号视频，1、2、3IO口，为0对应2号视频，4、5、6IO口
Private Sub timCapture1_Timer()
Dim iIn As Integer

    timCapture1.Enabled = False
    
    Call DelRec '删除无用数据
    
    iIn = vbInp(&H210)    ' 读IO口数据
    Call HandleInpShiZi(iIn)
    
    timCapture1.Enabled = True
End Sub

'针对一字行车情况，路灯状态单一
Private Sub timCapture2_Timer()
Dim iIn As Integer

    timCapture2.Enabled = False
    
    Call DelRec '删除无用数据
    
    iIn = vbInp(&H210)    ' 读IO口数据
    Call HandleInpYiZi(iIn)
    
    timCapture2.Enabled = True
End Sub

'处理第iIOch车道闯灯事件
Private Sub HandleCapture(ByVal iIOch As Integer)
Dim rs As Recordset
Dim FL As Long
Dim sFile As String
Dim tmpFile As String
Dim sRecText As String

    If bCh_OK(nCurVideoChannel) = False Then '如果摄像机损坏
        Exit Sub
    End If
    
    ' 抓拍图片
    Throw = CG200Capture(HCG200, False)
    tmpFile = GetAppPath & "Jpg\Tmp.bmp"
    Call MemToBmp(g_SCREEN_L, g_SCREEN_T, g_SCREEN_W, g_SCREEN_H, tmpFile)
    Throw = CG200Capture(HCG200, True)
    On Error Resume Next
    
    Image1.Picture = LoadPicture(GetAppPath & "Jpg\Tmp.bmp")
    sFile = GetCaptureJpgFile(nPostNo, iIOch)
    '存为Jpg格式
    Image1.SaveFileName = GetAppPath & "Jpg\" & sFile
    Image1.SaveFileType = FT_JPG
    Image1.SaveFile
    
    ' 形成抓拍记录
    nNewRecID = nNewRecID + 1
    Set rs = myDB.OpenRecordset("tabCaptureRec")
    rs.AddNew
    rs!fldID = nNewRecID
    rs!fldRoadNo = iIOch
    rs!fldDirection = sDirection((iIOch - 1) \ 3 + 1)
    rs!fldCapDate = Date
    rs!fldCapTime = Time
    rs!fldJpgFile = sFile
    rs!fldUpLoaded = False
    rs.Update

'加入列表中
    FL = FileLen(GetAppPath & "Jpg\" & rs!fldJpgFile)
    sRecText = "@" & Trim(rs!fldDirection) & _
               "@" & Format(rs!fldCapDate, "Long Date") & _
               "@" & Format(rs!fldCapTime, "Long Time") & _
               "@" & Trim(rs!fldJpgFile) & _
               "@" & Format(FL) & _
               "@"
    
    lstRecText.AddItem sRecText
    lstRecText.ItemData(lstRecText.NewIndex) = rs!fldID
    lstFile.AddItem rs!fldJpgFile
      
    rs.Close
End Sub

'获得Jpg文件
Private Function GetCaptureJpgFile(ByVal nConnorNo As Integer, ByVal nRoadNo As Integer) As String
Dim s As String, d As Date
    
    d = Now
    s = Format(Year(d)) & "-" & Format(Month(d)) & "-" & Format(Day(d)) & "-" & Format(Hour(d)) & "-" & Format(Minute(d)) & "-" & Format(Second(d))
    GetCaptureJpgFile = "C" & Format(nConnorNo) & "-" & "R" & Format(nRoadNo) & "-" & s & ".Jpg"
End Function

'获得当前路径
Private Function GetAppPath() As String
    If Right(App.Path, 1) = "\" Then
        GetAppPath = App.Path
    Else
        GetAppPath = App.Path & "\"
    End If
End Function

' 检查视频
Private Sub CheckVideo()
Dim n As Integer
Dim sFile As String
Dim i As Long, n0Count As Long
Dim x As Integer, y As Integer, c As Long

    If nDriveStyle = 1 Then '十字
        timCapture1.Enabled = False
    Else
        timCapture2.Enabled = False
    End If

    For n = 1 To 2
        If nCurVideoChannel <> n Then
            Call ChangeVideoChannel(n)
        End If
        Throw = CG200Capture(HCG200, False)
           
        sFile = "tmp" & Format(n) & ".bmp"
        Call MemToBmp(g_SCREEN_L, g_SCREEN_T, g_SCREEN_W, g_SCREEN_H, GetAppPath & "Jpg\" & sFile)
    
        Throw = CG200Capture(HCG200, True)
        On Error Resume Next
        picCheck.Picture = LoadPicture(GetAppPath & "Jpg\" & sFile)
    
        n0Count = 0
        For i = 0 To 800
            x = Rnd * picCheck.ScaleWidth
            y = Rnd * picCheck.ScaleHeight
            c = GetPixel(picCheck.hdc, x, y)
            If c = 0 Then
                n0Count = n0Count + 1
            End If
        Next i
        If n0Count > 500 Then
            bCh_OK(n) = False
        Else
            bCh_OK(n) = True
        End If
    Next n
    
    If nCurVideoChannel <> 2 Then   '切换回原来视频
        Call ChangeVideoChannel(nCurVideoChannel)
    End If
    
    If nDriveStyle = 1 Then '十字
        timCapture1.Enabled = True
    Else
        timCapture2.Enabled = True
    End If
End Sub

'初始化图像卡
Private Function InitCaptureCard() As Boolean
Dim i As Integer
    
    HCG200 = BeginCG200(1)
    
    If HCG200 = 0 Then
        For i = 0 To 2
            Beep
        Next i
        InitCaptureCard = False
    Else
        Throw = CG200WaitOddVSync(HCG200)
        Throw = CG200WaitVSync(HCG200)
        
        nCurVideoChannel = 1
        Throw = CG200SetADParam(HCG200, AD_SOURCE, nCurVideoChannel - 1)
        Throw = CG200SetDispMode(HCG200, FIELD)
        Throw = CG200SetInpVideoWindow(HCG200, 0, 0, g_PW, g_PH)
        Throw = CG200SetDispWindow(HCG200, g_SCREEN_L, g_SCREEN_T, g_SCREEN_W, g_PH)
        DoEvents
        'Throw = CG200Capture(HCG200, True)
        bCh_OK(1) = True
        bCh_OK(2) = True
        
        InitCaptureCard = True
    End If
End Function

'初始化抓拍设置
Private Function InitCaptureSet() As Boolean
Dim IniFile As String
Dim hFile As Integer
Dim Tmp As String
Dim i As Integer

    On Error Resume Next
    IniFile = GetAppPath & "Capture.ini"
    hFile = FreeFile
    Open IniFile For Input As #hFile
    If Err.Number <> 0 Then
        Close #hFile
        InitCaptureSet = False
    Else
        Input #hFile, Tmp
        Input #hFile, nPostNo       '路口编号
        Input #hFile, Tmp
        Input #hFile, nDriveStyle    '行车方式
        Input #hFile, Tmp
        For i = 1 To 2
            Input #hFile, Tmp, sDirection(i)    '行车方向
        Next i
        Input #hFile, Tmp
        Input #hFile, nChkVideoMax  '检查视频时间间隔
        Close #hFile
        InitCaptureSet = True
    End If
End Function

'初始化数据库，加载待上传记录
Private Sub InitMDB()
Dim rs As Recordset

    Set myDB = OpenDatabase(GetAppPath & "CaptureRec.mdb")
    
    Set rs = myDB.OpenRecordset("Select max(fldID) as maxID from tabCaptureRec", dbOpenSnapshot)
    If IsNull(rs!maxID) = False Then
        nNewRecID = rs!maxID
    Else
        nNewRecID = 0
    End If
    
    Call GetRecToSend
End Sub

'关闭图像卡
Private Sub CloseCaptureCard()
    Throw = CG200Capture(HCG200, False)
    Throw = EndCG200(HCG200)
End Sub

'关闭数据库
Private Sub CloseMDB()
    myDB.Close
End Sub

'关闭通讯端口
Private Sub CloseComm()
    Call HangUp
End Sub

'响应通讯端口数据接收事件
Private Sub MSComm1_OnComm()
Dim VARC As Variant, sJS As String
Dim n As Long, t As Single

    If bConnected = True Then    '处于连接状态则不响应此事件
        Exit Sub
    End If
    
    Select Case MSComm1.CommEvent
        Case comEvReceive
            n = MSComm1.InBufferCount
            MSComm1.InputLen = 0
            VARC = Space(n)
            VARC = MSComm1.Input
            sJS = HandleData(VARC)
            Text1.SelStart = Len(Text1.Text)
            Text1.SelLength = 0
            Text1.SelText = sJS
            
            If InStr(Text1.Text, "CONNECT") > 0 Or MSComm1.CDHolding = True Then
            '已经建立连接
                bConnected = True
                Call EchoOff(MSComm1)           '关掉返回结果码
                Call ResultCodesOff(MSComm1)    '关掉字符会应
                MSComm1.RThreshold = 0          '不再产生字符接收事件

                Call ChangeData         '进入数据交换状态
            End If
        Case Else
    End Select
End Sub

' 初始化通讯端口
Private Function InitComm() As Boolean
Dim commPort  As String
Dim commSettings As String
Dim commHandShaking As String
Dim An As Integer
    
    On Error Resume Next
    If MSComm1.PortOpen = True Then
        MSComm1.PortOpen = False
    End If
    
    commSettings = GetSetting("通讯端口设置", "Properties", "Settings", "")
    Do While commSettings = ""
        Load frmCommProperties
        Set frmCommProperties.frmComm = Me
        Call frmCommProperties.LoadPropertySettings

        frmCommProperties.Show vbModal
        If g_bCOMMSETOK = False Then
            An = MsgBox("您必须进行端口设置，否则程序无法运行" & vbCrLf & "重新设置吗？", vbYesNo + vbQuestion, "端口设置错误")