frmcom.frm

用vb编程实现对交通拍照的交通控制管理

        If Timer > t + Wait Then
            Exit Do
        ElseIf Timer < t And Timer > Wait Then
            Exit Do
        End If
        DoEvents
        If MSComm1.CDHolding = True Then
            Exit Do
        End If
    Loop
    
    If MSComm1.CDHolding = False Then
        ConnectClient = False
        Exit Function
    Else
        ConnectClient = True
        Set itemX = lstRun.ListItems.Add(, , "连接成功！")
        itemX.EnsureVisible
    End If
        
End Function

Private Sub Form_Unload(Cancel As Integer)
    Call HangUp
End Sub

'接收文件,定长数据块
Private Function GetFile(ByVal FileName As String, ByVal FileL As Long) As Boolean
Dim hJS As Integer, t As Single
Dim JSFileName As String
Dim JSLen As Long
Dim lWriteL As Long '实际要写入的文件数据长度

    prsFile.Max = FileL
    prsFile.Min = 0
    prsFile.Value = 0
    
    '打开接收文件
    hJS = FreeFile
    JSFileName = GetAppPath & "Jpg\" & FileName
    Open JSFileName For Binary Access Write As hJS
        
    '发送要文件命令
    If SendChar(GIVE_ME_FILE) = False Then
        Set itemX = lstRun.ListItems.Add(, , "发送GIVE_ME_FILE失败，文件接收失败")
        itemX.EnsureVisible
        GoTo WrongGetFile
    End If
    
    '接收文件内容，直到完全
    JSLen = 0
    Do While JSLen < FileL
        If FileL - JSLen > SENDDATALENGTH Then
            lWriteL = SENDDATALENGTH
        Else
            lWriteL = FileL - JSLen
        End If
            
        If GetFileData(lWriteL) = False Then
            Set itemX = lstRun.ListItems.Add(, , "文件接收失败")
            itemX.EnsureVisible
            GoTo WrongGetFile
        End If
        
        ReDim JSARR(1 To lWriteL)
        JSARR = JSFILEDATA
        
        '将字节型数组中的数据写入已打开的接收文件
        Put hJS, , JSARR
        JSLen = JSLen + lWriteL '本次已累计收到的字节数
        prsFile.Value = JSLen
        
        If JSLen < FileL Then
            '未完，则发送GIVE_ME_FILE
            If SendChar(GIVE_ME_FILE) = False Then
                Set itemX = lstRun.ListItems.Add(, , "继续发送GIVE_ME_FILE失败，文件接收失败")
                itemX.EnsureVisible
                GoTo WrongGetFile
            End If
        Else
            '文件传输已结束,关闭接收文件
            If SendChar(I_GET_IT) = False Then
                Set itemX = lstRun.ListItems.Add(, , "继续发送I_GET_IT失败，文件接收失败")
                itemX.EnsureVisible
                GoTo WrongGetFile
            End If
            '延迟
            t = Timer
            Do While Timer < t + 1
                If Timer < t Then
                    Exit Do
                End If
            Loop
            
            Close hJS
            Set itemX = lstRun.ListItems.Add(, , "文件接收成功")
            itemX.EnsureVisible
            prsFile.Value = 0
            GetFile = True

            Exit Function
        End If
    Loop

WrongGetFile:
    Close hJS
    prsFile.Value = 0
    GetFile = False
End Function

Private Sub HangUp()
Dim Ret
    If MSComm1.PortOpen = True Then
        MSComm1.Output = "ATH" & vbCrLf     ' 发送挂机字符串。
        Ret = MSComm1.DTREnable             ' 保存当前设置。
        MSComm1.DTREnable = True            ' 打开 DTR 。
        MSComm1.DTREnable = False           ' 关闭 DTR 。
        MSComm1.DTREnable = Ret             ' 恢复原来的设置。
        MSComm1.PortOpen = False
    End If
End Sub

'向终端发送字符串信息
Private Function SendChar(ByVal s As String) As Boolean
Dim t As Single
Dim vTmp As Variant

    '清空接收缓冲区
    MSComm1.InputLen = 0
    vTmp = MSComm1.Input
    
    t = Timer
    Do While 1
        If Timer > t + Wait Then
            Exit Do
        ElseIf Timer < t And Timer > Wait Then
            Exit Do
        End If
    
        If MSComm1.CTSHolding Then
            MSComm1.Output = s
            SendChar = True
            Exit Function
        End If
        DoEvents
    Loop
    
    SendChar = False
End Function

'接收终端传来的文本信息,以&*@结尾
Private Function GetReChar() As String
Dim t As Single
Dim JSData As Variant, JSstring As String

    '等待Wait 秒，如果无数据，则错误返回空字符串
    JSstring = ""
    t = Timer
    Do While 1
        If Timer > t + Wait Then
            Exit Do
        ElseIf Timer < t And Timer > Wait Then
            Exit Do
        End If
        If MSComm1.InBufferCount > 0 Then
            MSComm1.InputLen = 0
            JSData = MSComm1.Input
            JSstring = JSstring & HandleData(JSData)
            If InStr(1, JSstring, CHAREND) > 0 Then
                Exit Do
            End If
        End If
        DoEvents
    Loop
    
    GetReChar = JSstring
End Function

'接收终端传来的定长文件信息，二进制
Private Function GetFileData(ByVal lWL As Long) As Boolean
Dim t As Single
Dim tmp As Variant

    '转为二进制模式
    If MSComm1.InputMode = comInputModeText Then
        MSComm1.InputMode = comInputModeBinary
    End If
    
    '等待Wait 秒，如果无数据，则错误返回
    t = Timer
    Do While 1
        If Timer > t + Wait Then
            Exit Do
        ElseIf Timer < t And Timer > Wait Then
            Exit Do
        End If
        If MSComm1.InBufferCount < lWL Then
        Else
            ReDim tmpARR(1 To lWL)
            JSFILEDATA = tmpARR
            
            MSComm1.InputLen = lWL
            JSFILEDATA = MSComm1.Input
            
            '清空
            MSComm1.InputLen = 0
            tmp = MSComm1.Input
            
            GetFileData = True
            Exit Function
        End If
        DoEvents
    Loop
    
    GetFileData = False
End Function

'分析视频状态和待传记录数
's=@True@False@RecCount@
Private Function AnalyVandRecCount(ByVal s As String, bV1 As Boolean, bV2 As Boolean) As Integer
Dim iPosi1 As Integer, iPosi2 As Integer
Dim iPosi3 As Integer, iPosi4 As Integer

    iPosi1 = InStr(1, s, "@")
    If iPosi1 <= 0 Then
        AnalyVandRecCount = 0
        Exit Function
    End If
    
    iPosi2 = InStr(iPosi1 + 1, s, "@")
    iPosi3 = InStr(iPosi2 + 1, s, "@")
    iPosi4 = InStr(iPosi3 + 1, s, "@")
    
    bV1 = Mid(s, iPosi1 + 1, iPosi2 - iPosi1 - 1)
    bV2 = Mid(s, iPosi2 + 1, iPosi3 - iPosi2 - 1)
    AnalyVandRecCount = Val(Mid(s, iPosi3 + 1, iPosi4 - iPosi3 - 1))
End Function

'分析文本，返回文件名，并由FL返回文件长度
'sRecText=@行车方向@日期@时间@图片名称@文件长度@
'sRecText="@由东向西@2000年3月21日@17:12:[e-mail]@33068@"
Private Function AnalyRecText(ByVal sRecText As String, FL As Long) As String
Dim sDirection As String, sFile As String
Dim sDay As Date, sTime As Date
Dim nPos1 As Integer, nPos2 As Integer

    nPos1 = InStr(1, sRecText, "@")
    If nPos1 <= 0 Then
        AnalyRecText = ""
        Exit Function
    End If
    
    '行车方向
    nPos2 = InStr(nPos1 + 1, sRecText, "@")
    sDirection = Mid(sRecText, nPos1 + 1, nPos2 - nPos1 - 1)
    
    nPos1 = nPos2
    '日期
    nPos2 = InStr(nPos1 + 1, sRecText, "@")
    sDay = Mid(sRecText, nPos1 + 1, nPos2 - nPos1 - 1)
    
    nPos1 = nPos2
    '时间
    nPos2 = InStr(nPos1 + 1, sRecText, "@")
    sTime = Mid(sRecText, nPos1 + 1, nPos2 - nPos1 - 1)
    
    nPos1 = nPos2
    '图片文件
    nPos2 = InStr(nPos1 + 1, sRecText, "@")
    sFile = Mid(sRecText, nPos1 + 1, nPos2 - nPos1 - 1)

    nPos1 = nPos2
    '文件长度
    nPos2 = InStr(nPos1 + 1, sRecText, "@")
    FL = Val(Mid(sRecText, nPos1 + 1, nPos2 - nPos1 - 1))
    
    Set itemX = lstViwCapture.ListItems.Add(, , Format(lstViwCapture.ListItems.Count + 1))
    itemX.SubItems(1) = sClientNames(nCurrentClientNo)
    itemX.SubItems(2) = sDirection
    itemX.SubItems(3) = Format(sDay, "Long Date")
    itemX.SubItems(4) = Format(sTime, "Long Time")
    itemX.SubItems(5) = sFile
    Set lstViwCapture.SelectedItem = itemX
    
    AnalyRecText = sFile
End Function

'处理号码为sClientPhone 的终端工作状态
Private Sub WrongWorkClient(ByVal nWrong As Integer)
Dim i As Integer

    For i = 1 To frmMain.lstViwClients.ListItems.Count
        Set itemX = frmMain.lstViwClients.ListItems(i)
        If itemX.SubItems(1) = sClientNames(i) Then
            Exit For
        End If
    Next i
    
    itemX.Icon = 1
    itemX.SmallIcon = 1
    
    If nWrong = WRONG_NET Then
        itemX.SubItems(2) = "不通"
    ElseIf nWrong = WRONG_V1 Then
        itemX.SubItems(3) = "损坏"
    Else
        itemX.SubItems(4) = "损坏"
    End If
End Sub

'处理接收到的字符，去掉空格和回车换行符
Private Function HandleData(Data As Variant) As String
Dim i As Long
Dim 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 Sub AddNewRec()
Dim rs As Recordset
    
    Set itemX = lstViwCapture.SelectedItem
    '添加新纪录
    g_nNewRecID = g_nNewRecID + 1
    Set rs = g_myDB.OpenRecordset("tabCaptureRec")
    rs.AddNew
        rs!fldID = g_nNewRecID
        rs!fldPostName = itemX.SubItems(1)
        rs!fldDirection = itemX.SubItems(2)
        rs!fldCapDate = CDate(itemX.SubItems(3))
        rs!fldCapTime = CDate(itemX.SubItems(4))
        rs!fldJpgFile = itemX.SubItems(5)
        rs!fldPrinted = False
    rs.Update
    
    itemX.Tag = g_nNewRecID
    rs.Close
End Sub

'初始化列表
Private Sub InitLstViw()
Dim i As Integer

    lstRun.View = lvwReport
    lstRun.ColumnHeaders.Add , , "运行监视", 5000
    
    lstViwCapture.View = lvwReport
    lstViwCapture.ColumnHeaders.Add , , "No", 360
    lstViwCapture.ColumnHeaders.Add , , "      记录来源", 2700
    lstViwCapture.ColumnHeaders.Add , , "行驶方向", 1050
    lstViwCapture.ColumnHeaders.Add , , "拍照日期", 1265
    lstViwCapture.ColumnHeaders.Add , , "拍照时间", 1265
    lstViwCapture.ColumnHeaders.Add , , "图片名称", 0
    For i = 3 To lstViwCapture.ColumnHeaders.Count
        lstViwCapture.ColumnHeaders(i).Alignment = lvwColumnCenter
    Next i
End Sub

'设置终端数量和各个终端电话号码、名称
Public Sub GetClientsSetting()
Dim rs As Recordset, i As Integer

    Set rs = g_myDB.OpenRecordset("Select * from tabPostSettings where fldWork = True", dbOpenSnapshot)
    If rs.EOF Then
        nClientsCount = 0
    Else
        rs.MoveLast
        nClientsCount = rs.RecordCount
        ReDim sClientNames(1 To nClientsCount)
        ReDim sClientPhones(1 To nClientsCount)
        rs.MoveFirst
        For i = 1 To nClientsCount
            sClientPhones(i) = rs!fldPhoneNumber
            sClientNames(i) = rs!fldPostName
            rs.MoveNext
        Next i
    End If
    rs.Close
End Sub

'发送记录
Private Sub SendRecToMain()
Dim i As Integer, j As Integer
    
    If lstViwCapture.ListItems.Count <= 0 Then
        Exit Sub
    End If
    
    For i = 1 To lstViwCapture.ListItems.Count
        Set itemX = frmMain.lstViwCapture.ListItems.Add(, , Format(frmMain.lstViwCapture.ListItems.Count + 1))
        For j = 1 To 2
            itemX.SubItems(j) = lstViwCapture.ListItems(i).SubItems(j)
        Next j
        
        itemX.SubItems(3) = lstViwCapture.ListItems(i).SubItems(3) & lstViwCapture.ListItems(i).SubItems(4)
        itemX.SubItems(4) = lstViwCapture.ListItems(i).SubItems(5)
        itemX.Tag = lstViwCapture.ListItems(i).Tag
    Next i
    
    lstViwCapture.ListItems.Clear   '发送完毕后清除
End Sub

'禁止关闭窗体
Private Sub RemoveX(hWnd As Long)
Dim hMenu As Long
Dim menuItemCount As Long

    hMenu = GetSystemMenu(hWnd, 0)
    If hMenu Then
        menuItemCount = GetMenuItemCount(hMenu)
        RemoveMenu hMenu, menuItemCount - 1, MF_REMOVE Or MF_BYPOSITION
        RemoveMenu hMenu, menuItemCount - 2, MF_REMOVE Or MF_BYPOSITION
        DrawMenuBar hWnd
    End If
End Sub