pubfunc.bas

一个功能比较完善的远程抄表软件

                CollectUserData_pic = 5
'status
                AppendStatusInfo "用户" & curUserID & "表[" & curDevID & "]图像识别失败（5:文件格式错误）", icoRED
                SaveLog "用户" & curUserID & "表[" & curDevID & "]图像识别失败（5:文件格式错误）", 0
            Case -4
                CollectUserData_pic = 6
'status
                AppendStatusInfo "用户" & curUserID & "表[" & curDevID & "]图像识别失败（6:图象质量差,不能识别,请检查摄像头）", icoRED
                SaveLog "用户" & curUserID & "表[" & curDevID & "]图像识别失败（6:图象质量差,不能识别,请检查摄像头）", 0
            Case Is >= 0
                DData(curDevID) = temVal
                CollectUserData_pic = 0
'status
                AppendStatusInfo "用户" & curUserID & "表[" & curDevID & "]采集成功", icoBLUE
                SaveLog "用户" & curUserID & "表[" & curDevID & "]采集成功", 0
        End Select
    Else
        CollectUserData_pic = 2
    End If
    
End Function

'Function CollectUserData_pic_old(curUserID As Integer, UserAddress As Integer, curUserDevSum As Integer, curJPGDir As String) As Integer
''返回值:    0---正常采集
''           1---录像失败
''           2---抓取图像文件失败
''           3---图像识别失败(内存分配失败!)
''           4---图像识别失败(没有找到文件!)
''           5---图像识别失败(文件格式错误!)
''           6---图像识别失败(图象质量差,不能识别,请检查摄像头!)
''           7---采集被终止
''           其他---其他错误
'Dim RData(5) As Integer     '保存读脉冲取得的数据
'Dim temVal As Long
'Dim RFlag As Boolean        '读脉冲辅助标志,用于防止重复读取同一个脉冲
'Dim DFlag As Boolean        '换表脉冲辅助标志,用于防止重复读取同一个脉冲
'Dim CollectDevID As Integer
'Dim ReadCount As Integer    '有效读脉冲个数,用于在换表脉冲到来时,判断读脉冲是否检取正确
'                                '4位表,当换表脉冲到来时,该值应为4
'                                '5位表,当换表脉冲到来时,该值应为5
'Dim ok As Boolean
'
'    RFlag = True
'    DFlag = True
'    ReadCount = 0
'    CollectDevID = 0                    '用户设备数
'    ReDim DData(1)
'
''status
'    AppendStatusInfo "发送用户" & curUserID & "地址" & UserAddress, icoBLUE
'    SaveLog "发送用户" & curUserID & "地址" & UserAddress, 0
'    OpenUser (UserAddress)        '打开当前用户
'
'    Do While True
'        If pubTimerCount1 > gVideoCapDelay Then  '等待gCaptureDelay时间后开始抓取快照
'            pubTimer1.Enabled = False
'            pubTimer1.Interval = 0
'            pubTimerCount1 = 0
'
'            gCurJPGFile = curJPGDir & "\" & curUserID & "-" & CollectDevID & ".jpg"
'            If Dir(gCurJPGFile, 0) <> "" Then
'                Kill gCurJPGFile
'            End If
'            ok = frmMain.videoMain.SaveImageToJpg(gCurJPGFile, 100)     '抓取图像文件
'            Exit Do
'        End If
'        DoEvents
'    Loop
'
'    If ok = True Then
'        temVal = Translate(gCurJPGFile)       '进行图像识别
'        Select Case (temVal)
'            Case -1
'                CollectUserData_pic = 3
''status
'                AppendStatusInfo "用户" & curUserID & "图像识别失败（3）", icoBLUE
'                SaveLog "用户" & curUserID & "图像识别失败（3）", 0
'            Case -2
'                CollectUserData_pic = 4
''status
'                AppendStatusInfo "用户" & curUserID & "图像识别失败（4：没有找到文件）", icoBLUE
'                SaveLog "用户" & curUserID & "图像识别失败（4：没有找到文件）", 0
'            Case -3
'                CollectUserData_pic = 5
''status
'                AppendStatusInfo "用户" & curUserID & "图像识别失败（5:文件格式错误）", icoBLUE
'                SaveLog "用户" & curUserID & "图像识别失败（5:文件格式错误）", 0
'            Case -4
'                CollectUserData_pic = 6
''status
'                AppendStatusInfo "用户" & curUserID & "图像识别失败（6:图象质量差,不能识别,请检查摄像头）", icoBLUE
'                SaveLog "用户" & curUserID & "图像识别失败（6:图象质量差,不能识别,请检查摄像头）", 0
'            Case Is >= 0
'                DData(CollectDevID) = temVal
'                CollectUserData_pic = 0
''status
'                AppendStatusInfo "用户" & curUserID & "采集成功", icoBLUE
'                SaveLog "用户" & curUserID & "采集成功", 0
'        End Select
'    Else
'        CollectUserData_pic = 2
'    End If
'End Function
'
'
'延时函数
Function Delay(ByVal intervalTime As Integer, ByVal delaytime As Long) As Integer
    pubTimerDelay.Enabled = False
    pubTimerCountDelay = 0
    pubTimerDelay.Interval = intervalTime
    pubTimerDelay.Enabled = True
    DelayCancel = False
    Do While True
        If DelayCancel Then
            pubTimerDelay.Enabled = False
            pubTimerDelay.Interval = 0
            pubTimerCountDelay = 0
            Exit Do
        End If
        If pubTimerCountDelay >= delaytime Then
            pubTimerDelay.Enabled = False
            pubTimerDelay.Interval = 0
            pubTimerCountDelay = 0
            Exit Do
        End If
        DoEvents
    Loop
    Delay = 0
End Function

'给固定长度的字符串(内容为数字)添加前导字符
'参数说明:  fillStr---原字符串,fillLen---固定字符串长度
'当fillStr长度小于fillLen时,在前补fillChar中指定的字符串
Function FillHeadChar(fillStr As String, fillLen As Integer, fillChar As String) As String
Dim i As Integer
    
    fillChar = Trim(fillChar)
    If fillLen < 0 Then
        FillHeadZero = ""
        Exit Function
    End If
    FillHeadZero = Trim(fillStr)
    For i = 1 To fillLen - Len(fillStr)
        FillHeadZero = fillChar + FillHeadZero
    Next i
    
End Function


Function getAlertName(curAlertType As Integer) As String
    Select Case curAlertType
        Case 0
            getAlertName = "盗水,盗气"
        Case 1
            getAlertName = "煤气泄漏"
        Case 2
            getAlertName = "防盗报警"
        Case 8
            getAlertName = "老人救护"
        Case Else
            getAlertName = ""
    End Select
End Function

Function getUserStatusStr(StatusID As Integer) As String
    Select Case StatusID
        Case 0
            getUserStatusStr = " 正常采集完毕 "
        Case 1
            getUserStatusStr = " 用户板超时无反应 "
        Case 2
            getUserStatusStr = " 用户板信号错误2(丢失同步信号) "      '丢失换表脉冲
        Case 3
            getUserStatusStr = " 用户板信号错误3(丢失数据码) "      '丢失读脉冲
        Case 4
            getUserStatusStr = " 用户板信号错误4(丢失一表或多表数据)"
        Case 5
            getUserStatusStr = " 采集被强制中止 "
        Case 6
            getUserStatusStr = " 返回用户地址错误 "
        Case Else
            getUserStatusStr = " 用户板信号错误,返回错误信号" & StatusID      '其他未知原因
    End Select
End Function

Function getStatusStr(StatusID As Integer) As String
    If IsNull(StatusID) Then
        getStatusStr = "待测"
    Else
        Select Case StatusID
            Case 0
                getStatusStr = "待测"
            Case 1
                getStatusStr = "正常"
            Case Is > 1
                getStatusStr = "故障"
        End Select
    End If
End Function

'初始化采集卡系统变量
Sub initCard()
Dim rcBase As Recordset

'    Set rcBase = dbCbb.OpenRecordset("IOBase", dbOpenDynaset)
'    If rcBase.EOF Or rcBase.RecordCount <= 0 Then
'        rcBase.AddNew
'        rcBase!BaseAddr = Val("&H300")
'        rcBase.Update
'        BaseAddr = 300
'    Else
'        BaseAddr = rcBase!BaseAddr
'    End If
    PortA_1 = BaseAddr + 4
    PortB_1 = BaseAddr + 5
    PortC_1 = BaseAddr + 6
    Ctrl_1 = BaseAddr + 7
    PortA_2 = BaseAddr
    PortB_2 = BaseAddr + 1
    PortC_2 = BaseAddr + 2
    Ctrl_2 = BaseAddr + 3
    
    bRead1 = &H1
    bRead2 = &H10
    bDev = &H2
    bUser = &H4
    bEnd = &H8
    bAlert = &H40
    
    PORTC1_VAL = 0
    
    Init8255            '初始化采集卡8255
End Sub


Sub initSysVar()
    ReDim curForm(0)
    
    LGate = 1
    UGate = 20
    LBuild = 21
    UBuild = 50
    LUser = 51
    UUser = 2187    '7位地址码,三态,3^7=2187,2187-50=2137总共可支持213户
    
    QuitAlert = False
    Alerting = False
    
    RED = &HC0&
    GREEN = &H8000&
    BLUE = &HFFFF00
    DARKGRAY = &H808080
    SYS_COLOR = &H8000000F

    
Dim rcBit As Recordset

'    Set rcBit = dbCbb.OpenRecordset("Bit", dbOpenDynaset)
'    If rcBit.RecordCount <= 0 Then
'        rcBit.AddNew
'        rcBit!BitType = 4
'        rcBit.Update
'    End If
'    curBit = rcBit!BitType
'    rcBit.Close
    
    Set curAlertForm(1) = New frmCurAlert
    Set curAlertForm(2) = New frmCurAlert
    Set curAlertForm(3) = New frmCurAlert
    Set curAlertForm(4) = New frmCurAlert
    
Dim rcAddr As Recordset

    Set rcAddr = dbCbb.OpenRecordset("AddrMap", dbOpenDynaset)
    If rcAddr.RecordCount <= 0 Then
        rcAddr.AddNew
        rcAddr!gate = 20
        rcAddr!Build = 30
        rcAddr!User = 2000
        rcAddr.Update
    End If
        rcAddr.MoveFirst
        If rcAddr!gate > 0 Then
            LGate = 1
            UGate = rcAddr!gate
        Else
            LGate = 0
            UGate = 0
        End If
        If rcAddr!Build > 0 Then
            LBuild = UGate + 1
            UBuild = rcAddr!Build + LBuild - 1
        Else
            LBuild = 0
            UBuild = 0
        End If
        If rcAddr!User > 0 Then
            LUser = UBuild + 1
            UUser = rcAddr!User + LUser - 1
        Else
            LUser = 0
            UUser = 0
        End If
        
End Sub
Sub Main()
Dim fRepair As Boolean
Dim fRestore As Boolean
Dim temVal As Boolean

    fRepair = True
    fRestore = True
        
    If Dir(App.Path & "\log", 16) = "" Then
        MkDir App.Path & "\log"
    End If
    If Dir(App.Path & "\bak", 16) = "" Then
        MkDir App.Path & "\bak"
    End If
    If Dir$(App.Path & "\first.id", 0) = "" Then
        If Dir$(App.Path & "\cbb.mdb", 0) <> "" Then
            If Dir$(App.Path & "\data", 16) <> "" Then
                If Dir$(App.Path & "\data\cbb.mdb", 0) <> "" Then
                    If MsgBox("检测到以前的数据文件" + Chr(10) + "要覆盖吗?", 48 + 1 + 256, "CBB系统检测") = 2 Then
                        GoTo FirstThen
                    End If
                End If
            Else
                MkDir App.Path & "\data"
            End If
            FileCopy App.Path & "\cbb.mdb", App.Path & "\data\cbb.mdb"
            FileCopy App.Path & "\CBB.MDB", App.Path & "\DATA\CBB_BK.MDB"
        Else
            MsgBox "找不到系统文件 CBB.MDB" + Chr(10) + "系统无法继续执行!", 48, "CBB系统检测"
            End
        End If
FirstThen:
        If Dir$(App.Path & "\data", 16) <> "" Then
                If Dir$(App.Path & "\userdata.rpt", 0) = "" Then
                    If Dir$(App.Path & "\data\userdata.rpt", 0) = "" Then
                        MsgBox "找不到系统报表文件 ""USERDATA.RPT""" + Chr(10) + "系统无法进行打印!", 48, "CBB系统检测"
                    End If
                Else
                    FileCopy App.Path & "\userdata.rpt", App.Path & "\data\userdata.rpt"
                End If
        Else
            MkDir App.Path & "\data"
            If Dir$(App.Path & "\userdata.rpt", 0) = "" Then
                MsgBox "找不到系统报表文件 ""USERDATA.RPT""" + Chr(10) + "系统无法进行打印!", 48, "CBB系统检测"
            Else
                FileCopy App.Path & "\userdata.rpt", App.Path & "\data\userdata.rpt"
            End If
        End If
        
        Dim hFirst As Integer
        hFirst = FreeFile
        Open "first.id" For Binary As #hFirst
        Close #hFirst
    End If
    
    
    If Dir$(App.Path & "\data", 16) <> "" Then
        If Dir$(App.Path & "\data\cbb.mdb", 0) = "" Then
            If Dir$(App.Path & "\DATA\CBB_BK.MDB", 0) <> "" Then
                If MsgBox("系统库""CBB.MDB""丢失" + Chr(10) + "使用系统备份库CBB_BK.MDB恢复吗?", 48 + 1, "CBB系统检测") = 1 Then