frmcommclient.frm

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

'接收服务器传来的字符信息
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
Dim rs As Recordset
Dim bV1 As Boolean, bV2 As Boolean


    '此处要调用检查视频工作是否正常函数
    bV1 = True
    bV2 = True
    '检查数据库，抽取待传信息
    
    GetVideoAndRec = "@" & Format(bV1) & "@" & Format(bV1) & "@" & Format(lstRec.ListCount) & "@"
End Function

'向服务器发送定长文本信息，不足以空格补充
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(lstRec.List(recNo)) = False Then
        GoTo ExitSendRec
    End If
Text1.Text = Text1.Text & "SendChar： " & lstRec.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

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 < lstRec.ListCount
        If SendRec(i) = True Then   '发送成功
        '改写数据库记录，标识已经发送
        
        End If
        
        '下一条记录
        i = i + 1
    Loop
    
ExitChangData:
    Call HangUp
    Call InitComm
End Sub

'加载待传记录信息
Private Sub GetRecToSend()
Dim FL As Long
Dim TestFile As String

lstRec.Clear
lstFile.Clear

    TestFile = "1.jpg"
    FL = FileLen(GetAppPath & "Jpg\" & TestFile)
    lstRec.AddItem "@" & TestFile & "@" & Format(FL) & "@"
    lstFile.AddItem TestFile

    TestFile = "1.txt"
    FL = FileLen(GetAppPath & "Jpg\" & TestFile)
    lstRec.AddItem "@" & TestFile & "@" & Format(FL) & "@"
    lstFile.AddItem TestFile

    TestFile = "2.txt"
    FL = FileLen(GetAppPath & "Jpg\" & TestFile)
    lstRec.AddItem "@" & TestFile & "@" & Format(FL) & "@"
    lstFile.AddItem TestFile

    TestFile = "3.txt"
    FL = FileLen(GetAppPath & "Jpg\" & TestFile)
    lstRec.AddItem "@" & TestFile & "@" & Format(FL) & "@"
    lstFile.AddItem TestFile
End Sub