frmcapture.frm

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

            If An = vbNo Then
                InitComm = False
                Exit Function
            End If
        Else
            Exit Do
        End If
    Loop

    commSettings = GetSetting("通讯端口设置", "Properties", "Settings", "")
    commPort = GetSetting("通讯端口设置", "Properties", "CommPort", "")
    commHandShaking = GetSetting("通讯端口设置", "Properties", "Handshaking", "")
    
    MSComm1.Settings = commSettings
    MSComm1.commPort = commPort
    MSComm1.Handshaking = commHandShaking
    MSComm1.RThreshold = 1  '产生comEvReceive事件
    MSComm1.PortOpen = True
    bConnected = False
    
    If Err = 0 Then
        MSComm1.DTREnable = True
        Dim t As Single
        t = Timer + g_WAIT
        Do While Timer < t
            If MSComm1.CTSHolding = True Then
                Exit Do
            End If
            DoEvents
        Loop
        
        If MSComm1.CTSHolding = True Then
            Call EchoOn(MSComm1)            '打开字符回应
            Call ResultCodesOn(MSComm1)     '返回结果码
            Call SpeakerOff(MSComm1)        '关闭扬声器
            Call AnswerAuto(MSComm1)        '自动应答

            Text1.Text = ""
            Label1.Caption = ""
            InitComm = True
        Else
            InitComm = False
        End If
    Else
        InitComm = False
    End If
End Function

'挂断电话连接
Private Sub HangUp()
Dim RET
    If MSComm1.PortOpen = True Then
        Do While MSComm1.OutBufferCount > 0
        Loop
        
        Call OffHook(MSComm1)
        RET = MSComm1.DTREnable             ' 保存当前设置。
        MSComm1.DTREnable = True            ' 打开 DTR 。
        MSComm1.DTREnable = False           ' 关闭 DTR 。
        MSComm1.DTREnable = True            ' 打开 DTR 。
        MSComm1.DTREnable = RET             ' 恢复原来的设置。
        Call Reset(MSComm1)                 '
        MSComm1.PortOpen = False
    End If
End Sub

'处理接收到的字符，去掉空格和回车换行符
Private Function HandleData(Data As Variant) As String
Dim i As Long, s As String

    If MSComm1.InputMode = comInputModeBinary Then
        s = StrConv(Data, vbUnicode)
    Else
        s = Data
    End If
    s = Trim(s)
    ' 过滤/处理空格符。
    Do
       i = InStr(s, " ")
       If i Then
          If i = 1 Then
             s = Mid(s, i + 1)
          Else
             s = left(s, i - 1) & Mid(s, i + 1)
          End If
       End If
    Loop While i

    ' 除去换行符。
    Do
       i = InStr(s, Chr$(10))
       If i Then
          s = left$(s, i - 1) & Mid$(s, i + 1)
       End If
    Loop While i
    
    ' 除去回车符。
    Do
       i = InStr(s, Chr$(13))
       If i Then
          s = left$(s, i - 1) & Mid$(s, i + 1)
       End If
    Loop While i
    
    HandleData = s
End Function

'接收服务器传来的字符信息
Private Function GetReChar(ByVal nChrCount As Integer) As String
Dim t As Single
Dim JSData As Variant, JSstring As String

    '等待g_WAIT 秒，如果无数据，则错误返回空字符串
    t = Timer + g_WAIT
    JSstring = ""
    Do While Timer < t
        If MSComm1.InBufferCount < nChrCount Then
        Else
            JSData = Space(MSComm1.InBufferCount)
            MSComm1.InputLen = 0
            JSData = MSComm1.Input
            JSstring = HandleData(JSData)
            Exit Do
        End If
        DoEvents
    Loop
    
    GetReChar = JSstring
End Function

'获取视频状态和待传记录数
'记录的文本信息保存于LstRec中，图片文件名在lstFile中
'不必现从数据库中读取，而是随时将新记录信息保存
'当程序启动时，先装载待传记录信息
'*************************************
Private Function GetVideoAndRec() As String
    GetVideoAndRec = "@" & Format(bCh_OK(1)) & "@" & Format(bCh_OK(2)) & "@" & Format(lstRecText.ListCount) & "@"
End Function

'向服务器发送文本信息，以g_CHARENDN结尾
Private Function SendChar(ByVal s As String) As Boolean
Dim t As Single, Tmp As Variant
Dim sSend As String, i As Integer

    sSend = Trim(s) & g_CHAREND

    '清空接收缓冲区
    MSComm1.InputLen = 0
    Tmp = MSComm1.Input
    
    t = Timer + g_WAIT
    Do While Timer < t
        If MSComm1.CTSHolding Then
            MSComm1.Output = sSend
            SendChar = True
            Exit Function
        End If
        DoEvents
    Loop
    
    SendChar = False
End Function

'发送一个文件
Private Function SendFile(ByVal SendFileName As String) As Boolean
Dim hSend As Integer, FileLen As Long
Dim VARC As Variant, sGet As String
Dim bSendOK As Boolean, t As Single
Dim SednVar As Variant
Dim Sum As Long, BSize As Long

    On Error Resume Next

    '打开文件
    hSend = FreeFile
    Open GetAppPath & "Jpg\" & SendFileName For Binary Access Read As hSend
    If Err.Number <> 0 Then
        Close hSend
        SendFile = False
        Exit Function
    End If

Text1.Text = Text1.Text & "开始文件发送" & vbCrLf

    FileLen = LOF(hSend)  '文件长度
    Sum = 0 '记录累计发送的字节数
    Do While Sum < FileLen
        If FileLen - Loc(hSend) < g_SENDDATALENGTH Then
            BSize = FileLen - Loc(hSend)
        Else
            BSize = g_SENDDATALENGTH
        End If
        'ReDim SednArr(1 To g_SENDDATALENGTH)
        
        Get hSend, , SednArr    '从文件取字节放入字节数组
        Sum = Sum + BSize       '累加计数
        SednVar = SednArr       '转放到Variant型变量
        
        '当CTS线为高电平时才可发送，否则需等待。
        bSendOK = False
        t = Timer + g_WAIT
        Do While Timer < t
            If MSComm1.CTSHolding Then
                MSComm1.Output = SednVar    '发送文件数据
                If Sum = FileLen Then       '达到了文件尾
                    Dim tt As Single
                    tt = Timer + 1   '加延迟，解决收不到文件尾问题
                    Do While Timer < tt
                    Loop
                End If
Label1.Caption = "Length=" & Format(FileLen) & "  Send= " & Format(Sum)
                bSendOK = True
                Exit Do
            End If
            DoEvents
        Loop
        
        If bSendOK = False Then
            GoTo WrongSend
        End If
        
        '等待系统处理完
        bSendOK = False
        t = Timer + g_WAIT
        Do While Timer < t
            If MSComm1.OutBufferCount = 0 Then
                bSendOK = True
                Exit Do
            End If
            DoEvents
        Loop
        
        If bSendOK = False Then
            GoTo WrongSend
        End If
        
        '检查是否到了文件尾,到了则等待服务器的g_I_GET_IT信号以便确认当前记录发送成功
        '否则等待服务器方发送GIVE_ME_F信号，以便继续发送文件内容
        sGet = GetReChar(Len(g_GIVE_ME_FILE))
        If Sum = FileLen Then
            If InStr(sGet, g_I_GET_IT) <= 0 Then
                GoTo WrongSend
            Else
                Exit Do
            End If
        Else
            If InStr(sGet, g_GIVE_ME_FILE) <= 0 Then
                GoTo WrongSend
            End If
        End If
    Loop '循环语句结尾

    Close hSend
    SendFile = True
    Exit Function

WrongSend:
    Close hSend
    SendFile = False
End Function

'发送第recNo条记录，包括文本和图片文件
Private Function SendRec(ByVal recNo As Integer) As Boolean
Dim sGet As String
Dim i As Integer

    '获取服务器要记录信息命令
    sGet = GetReChar(Len(g_GIVE_ME_REC))
    If InStr(sGet, g_GIVE_ME_REC) <= 0 Then
        GoTo ExitSendRec
    End If
Text1.Text = Text1.Text & "Get g_GIVE_ME_REC ok" & vbCrLf
        
    '发送第recNo条记录的文本信息
    If SendChar(lstRecText.List(recNo)) = False Then
        GoTo ExitSendRec
    End If
Text1.Text = Text1.Text & "SendChar： " & lstRecText.List(recNo) & "  ok" & vbCrLf
        
    '获取服务器要文件命令
    sGet = GetReChar(Len(g_GIVE_ME_FILE))
    If InStr(sGet, g_GIVE_ME_FILE) <= 0 Then
        GoTo ExitSendRec
    End If
Text1.Text = Text1.Text & "Get g_GIVE_ME_FILE ok" & vbCrLf

    '发送文件lstFile.List(recNo)
    If SendFile(lstFile.List(recNo)) = False Then
        GoTo ExitSendRec
    End If
    
    SendRec = True
    Exit Function

ExitSendRec:
    Text1.Text = Text1.Text & "发送文件" & lstFile.List(recNo) & "失败" & vbCrLf
    SendRec = False
End Function

'与服务器进行数据交换
Private Sub ChangeData()
Dim sGet As String
Dim sVideoandRecCount As String
Dim i As Integer, rs As Recordset
Dim nRecCount As Integer

    If nDriveStyle = 1 Then '十字
        timCapture1.Enabled = False
    Else
        timCapture2.Enabled = False
    End If
        
Text1.Text = Text1.Text & "数据交换开始" & vbCrLf
    '等待并获取服务器要数据命令g_GIVE_ME_DATA
    sGet = GetReChar(Len(g_GIVE_ME_DATA))
    If InStr(sGet, g_GIVE_ME_DATA) <= 0 Then
        GoTo ExitChangData
    End If
Text1.Text = Text1.Text & "sGetString=" & sGet & vbCrLf
    
    '获取视频状态和待传记录数，记录信息保存于LstRec中
    sVideoandRecCount = GetVideoAndRec
    
    '发送视频状态和待传记录数
    If SendChar(sVideoandRecCount) = False Then
        GoTo ExitChangData
    End If
Text1.Text = Text1.Text & "SendString: " & sVideoandRecCount & "ok" & vbCrLf
    
    '顺序发送待发记录信息
    i = 0
    Do While i < lstRecText.ListCount
        If SendRec(i) = True Then   '发送成功
        '改写数据库记录，标识已经发送
            Set rs = myDB.OpenRecordset("Select * from tabCaptureRec where fldID =" & Format(lstRecText.ItemData(i)))
            rs.Edit
            rs!fldUpLoaded = True
            rs.Update
            rs.Close
            
            lstFile.ItemData(i) = 1 '成功发送
        End If
        
        '下一条记录
        i = i + 1
    Loop
        
    '应该等待服务器发送信息
    sGet = GetReChar(Len(g_I_GET_ALL_REC))
    
ExitChangData:
    Call HangUp
    Call InitComm
    Call GetRecToSend

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

'加载待传记录信息
'sRecText=@行车方向@日期@时间@图片名称@文件长度@
Private Sub GetRecToSend()
Dim rs As Recordset
Dim FL As Long
Dim sRecText As String

lstRecText.Clear
lstFile.Clear

    Set rs = myDB.OpenRecordset("Select * from tabCaptureRec where fldUpLoaded = False", dbOpenSnapshot)
    Do While Not rs.EOF
        On Error Resume Next
        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
        lstFile.ItemData(lstFile.NewIndex) = 0  '待传
        
        rs.MoveNext
    Loop
    rs.Close
End Sub

Private Sub ChangeVideoChannel(ByVal ch As Integer)
Dim t As Single
    
    nCurVideoChannel = ch
    Throw = CG200SetADParam(HCG200, AD_SOURCE, nCurVideoChannel - 1)
    DoEvents
    t = Timer + 0.25
    Do While Timer < t
        DoEvents
    Loop
End Sub

'删除半月前已上传记录，每天都删
Private Sub DelRec()
Dim cDay As Date
Dim rs As Recordset
Dim sFile As String

    cDay = Date
    If cDay <> dLastDelDay Then
        Set rs = myDB.OpenRecordset("Select * from tabCaptureRec where fldCapDate < #" & (cDay - 15) & "# and fldUpLoaded = True")
        Do While Not rs.EOF
            sFile = GetAppPath & "Jpg\" & rs!fldJpgFile
            Kill sFile
            rs.Delete
            rs.MoveFirst
        Loop
        rs.Close
        
        dLastDelDay = cDay
    End If
End Sub

'处理十字路口信号触发
Private Sub HandleInpShiZi(ByVal iIn As Integer)
Dim nRandBState As Integer
Dim i As Integer, nSign As Integer
    
    nRandBState = iIn And 1 '路灯状态
    If nRandBState = 0 Then '检查1、2、3口
        If nCurVideoChannel = 2 Then
            nCurVideoChannel = 1
            Throw = CG200SetADParam(HCG200, AD_SOURCE, nCurVideoChannel - 1)
        End If
        For i = 1 To 3      '检查1、2、3口，不用则总是低电平
            nSign = iIn And (2 ^ i) '检验第i个传感器是否有信号
            If nSign <> 0 Then  '有信号
                Call HandleCapture(i)
            End If
        Next i
    Else
        If nCurVideoChannel = 1 Then
            nCurVideoChannel = 2
            Throw = CG200SetADParam(HCG200, AD_SOURCE, nCurVideoChannel - 1)
        End If
        For i = 4 To 6      '检查4、5、6口，不用则总是低电平
            nSign = iIn And (2 ^ i) '检验第i个传感器是否有信号
            If nSign <> 0 Then  '有信号
                Call HandleCapture(i)
            End If
        Next i
    End If
End Sub

'处理一字路口信号触发
Private Sub HandleInpYiZi(ByVal iIn As Integer)
Dim nRandBState As Integer
Dim i As Integer, nSign As Integer
    
    nRandBState = iIn And 1 '路灯状态
    If nRandBState <> 0 Then   '无效的路灯状态
        Exit Sub
    End If
    
    '检测6个IO口，不用则总是低电平
    For i = 1 To 6
        nSign = iIn And (2 ^ i) '检验第i个传感器是否有信号
        If nSign <> 0 Then  '有信号
            If nCurVideoChannel <> ((i - 1) \ 3) + 1 Then
            '不是当前视频输入下的IO触发，需要切换视频
                Call ChangeVideoChannel(((i - 1) \ 3) + 1)
            End If
            Call HandleCapture(i)
        End If
    Next i
End Sub