mdlfunction.bas

针对银行排队

Attribute VB_Name = "MdlBaseFunction"

Public Const QueueFile = ".\queue.dat"      '队列文件名称
Public Const QueueFileDateLen = 14          '队列文件头部日期长度
Public Const intRecordLen = 15              '一条排队记录长度
Public Const intSerialNumLen = 5            '一条排队记录中序号的长度
Public Const intStatusLen = 1               '一条排队记录中状态的长度
Public Const intTimeMarkLen = 6             '一条排队记录中时间的长度

Public gintTimerInterval As Integer         '定时器间隔

Public gstrQueue As String                  '排队记录内容

Public gNurseStatus() As Integer             '护士台工作状态标识，0为空闲，1为工作

Public gQueueFileName As String

Public gintDelayTime As Integer       '记录本次程序启动时从叫号到该人从队列中删除之间的时间，以秒计
Public gNurseNum As Integer        '记录本次程序启动时采血护士个数


Public Declare Function GetTickCount Lib "kernel32" () As Long


'设置程序界面
Public Sub SetInterface()
    FrmMain.Top = 0
    FrmMain.Left = 0
    
    FrmMain.ImgBottom.Left = FrmMain.Left
    FrmMain.ImgBottom.Top = FrmMain.Top
    FrmMain.ImgBottom.Width = FrmMain.Width
    FrmMain.ImgBottom.Height = FrmMain.Height
    
    FrmMain.CmdPrintHT.Left = FrmMain.ImgBottom.Width / 2 - FrmMain.CmdPrintHT.Width / 2
    FrmMain.CmdPrintHT.Top = FrmMain.ImgBottom.Height / 2 - FrmMain.CmdPrintHT.Height / 2
End Sub


'取初始运行参数
Public Sub GetIniParameter()
    gintDelayTime = GetINI(App.Path & "\Config.ini", "Parameter", "Delay", 0)
    gNurseNum = GetINI(App.Path & "\Config.ini", "Parameter", "NurseNum", 0)
    gintTimerInterval = GetINI(App.Path & "\Config.ini", "Parameter", "CheckInterval", 0)
End Sub

'初始化队列文件
'读取队列文件，如不为空，说明是断电重启，则重新叫号，如文件不存在，则创建队列文件，如存在空文件，不做任何处理
Public Sub InitFile()
        
    Dim strQueue As String
    '判断队列文件是否存在
    If Dir(gQueueFileName) = "" Then
        '队列文件不存在,创建之
        CreateQueuefile gQueueFileName
        gstrQueue = ReadQueue(gQueueFileName)
        Exit Sub
    Else
        '存在队列文件，读取队列文件
        gstrQueue = ReadQueue(gQueueFileName)
        'MsgBox Mid(strQueue, 1, 1)
        
        If Len(gstrQueue) > QueueFileDateLen + 2 Then
            '如果文件长度大于日期头长度，则说明该次启动是由于系统故障重启,则从头开始叫号
            
            '重置队列文件中所有记录的状态为1,等待计时器中断
            initQueueStatus "1"
            
            '叫号
'            SpeakQueue gstrQueue
        End If
    End If

End Sub


'将第intN条记录的状态置为strSta
Public Sub SetQueueRecordStatus(intN As Integer, strSta As String)
    Dim strHead As String
    Dim strTail As String
    
    If Len(gstrQueue) > QueueFileDateLen + 2 Then
        '如果有排队记录
        strHead = Mid(gstrQueue, 1, QueueFileDateLen + (intN - 1) * intRecordLen + intSerialNumLen + 2)
        strTail = Mid(gstrQueue, 1 + QueueFileDateLen + (intN - 1) * intRecordLen + intSerialNumLen + 3)
        
        gstrQueue = strHead & strSta & strTail
    End If
    
End Sub

'从队列文件头叫号子过程,strQueue是队列文件内容
Public Sub SpeakQueue(strQueue As String)
    Dim strTmp As String
    Dim str1 As String
    Dim intTemp As Integer
    Dim i As Integer
    Dim intRecordNum As Long      '记录排队记录条数
    
    
    intRecordNum = GetRecordNum()
    
    If intRecordNum > gNurseNum Then
        '记录数大于护士台个数，按护士台个数播放队列记录
        For i = 1 To gNurseNum
            '播放排队记录的语音
            SpeakRecord i, i
            '延时3秒
            Call TimeDelay(3000)

            '记录时间戳
            strTmp = GetQueueRecord(i)
            strTmp = WriteTimeMark(strTmp)
    
            '将记录了时间戳的记录写回队列字符串
            gstrQueue = RewriteQueue(strQueue, strTmp, i)
        Next i
    Else
        '记录数大于护士台个数，按护士台个数播放队列记录
        For i = 1 To intRecordNum
            '播放排队记录的语音
            SpeakRecord i, i
            
            '延时3秒
            Call TimeDelay(3000)
            
            '记录时间戳
            strTmp = GetQueueRecord(i)
            strTmp = WriteTimeMark(strTmp)
    
            '将记录了时间戳的记录写回队列字符串
            gstrQueue = RewriteQueue(strQueue, strTmp, i)
        Next i
    End If
    
    '为与内存中的队列记录保持一致，将记录了时间戳的记录写回文件
    RewriteQueueFile gstrQueue
    
End Sub


'删除排队记录中超时的记录
Public Function DeleteTimeoutRecord() As String
    Dim i As Integer
    Dim intRecordNum As Long
    Dim strRecordTmp As String
    Dim strQueueTmp As String
    Dim intStatusTmp As Integer
    Dim intTimeMarkMinus As Integer
    
    '构造新的队列数据头部
    strQueueTmp = Mid(gstrQueue, 1, QueueFileDateLen)
    '取得当前队列中记录数
    intRecordNum = GetRecordNum()
    
    If intRecordNum > 0 Then
        For i = 1 To intRecordNum
            strRecordTmp = GetQueueRecord(i)
            intStatusTmp = CInt(GetRecordStatus(strRecordTmp))
            intTimeMarkMinus = TimeCompare(GetTimeMark(), GetRecordTime(strRecordTmp))
            If intStatusTmp = 2 Then
                '如果该号已叫过
                If intTimeMarkMinus < gintDelayTime Then
                    strQueueTmp = strQueueTmp & strRecordTmp
                End If
            Else
                strQueueTmp = strQueueTmp & strRecordTmp
            End If
        Next i
    End If

    gstrQueue = strQueueTmp
    RewriteQueueFile (gstrQueue)
    
    DeleteTimeoutRecord = gstrQueue
End Function

'用第一个参数代表的时间字符串与第二个参数代表的时间字符串比较，以秒为单位返回相差时间
Public Function TimeCompare(strCurr As String, strOld As String) As Integer
    Dim intCurrTmp As Long
    Dim intOldTmp As Long
    
    intCurrTmp = CLng(Mid(strCurr, 1, 2)) * 3600 + CInt(Mid(strCurr, 3, 2) * 60) + CInt(Mid(strCurr, 5, 2))
    intcurrold = CLng(Mid(strOld, 1, 2)) * 3600 + CInt(Mid(strOld, 3, 2) * 60) + CInt(Mid(strOld, 5, 2))
    
    TimeCompare = intCurrTmp - intcurrold
    
End Function

'
''取得当前时间，以整数形式返回
'Public Function GetCurrentTime() As String
'
'    GetCurrentTime = CStr(Hour(Time)) & CStr(Minute(Time)) & CStr(Second(Time))
'
'End Function


'播报第intI条队列记录到第intN号护士台
Public Sub SpeakRecord(intI As Integer, intN As Integer)
    Dim strTemp As String
    Dim str1 As String
    
    strTemp = Mid(gstrQueue, QueueFileDateLen + (intI - 1) * intRecordLen + 1, intRecordLen)
    str1 = GetRecordStrSerialNum(strTemp)
    
    '组合语音字符串
    strTemp = "请" & str1 & "号到第" & CStr(intN) & "抽血台抽血"

    SpeakString strTemp
End Sub

'将记录了时间戳的记录写回队列字符串,str为队列字符串，strT为一条记录，intS为记录的序号
Public Function RewriteQueue(strQ As String, strT As String, intS As Integer) As String
    Dim intTmp As Integer
    Dim strTempHead, strTempTail As String
    
    intTmp = (intS - 1) * intRecordLen
    strTempHead = Mid(strQ, 1, QueueFileDateLen + (intS - 1) * intRecordLen)
    
    If CInt((Len(strQ) - QueueFileDateLen) / intRecordLen) = intS Then
        strTempTail = ""
    Else
        strTempTail = Mid(strQ, QueueFileDateLen + intS * intRecordLen + 1)
    End If
    
    RewriteQueue = strTempHead & strT & strTempTail

End Function


'将内存中的队列字符串回写到文件中，str为队列字符串，strT为一条记录，intS为记录的序号
Public Sub RewriteQueueFile(strQ As String)
   Dim FileNumber
   
   FileNumber = FreeFile   ' 取得未使用的文件号。
   Open gQueueFileName For Output As #FileNumber   ' 创建文件名。
   Write #FileNumber, strQ '    输出文本至文件中
   Close #FileNumber   ' 关闭文件。

End Sub

'重置所有排队记录的状态值为strSta
Public Sub initQueueStatus(strSta As String)
    Dim i As Integer
    Dim intRecordNum As Integer
    
    If Len(gstrQueue) > QueueFileDateLen + 2 Then
        '有排队记录
        intRecordNum = CInt(Len(gstrQueue) - QueueFileDateLen - 2) / intRecordLen
        For i = 1 To intRecordNum
            SetQueueRecordStatus i, strSta
        Next
        RewriteQueueFile gstrQueue
    End If
End Sub

'取得并格式化当前时间字符串
Public Function GetTimeMark() As String
    Dim str1 As String
    Dim intTemp As Integer
    
    '将时间经过格式化后记录在str1中
    intTemp = Hour(Time)
    If Len(CStr(intTemp)) = 1 Then
        str1 = "0" & CStr(intTemp)
    Else
        str1 = CStr(intTemp)
    End If
    
    intTemp = Minute(Time)
    If Len(CStr(intTemp)) = 1 Then
        str1 = str1 & "0" & CStr(intTemp)
    Else
        str1 = str1 & CStr(intTemp)
    End If
    
    intTemp = Second(Time)
    If Len(CStr(intTemp)) = 1 Then
        str1 = str1 & "0" & CStr(intTemp)
    Else
        str1 = str1 & CStr(intTemp)
    End If
    
    GetTimeMark = str1
End Function


'向记录字段中的相应位置重写时间戳
Public Function WriteTimeMark(strTemp As String) As String
    Dim intTemp As Integer
    Dim str1 As String
    
    '将时间经过格式化后记录在str1中
    str1 = GetTimeMark()
    
    '将该条记录的状态值改为2
    strTemp = Mid(strTemp, 1, intSerialNumLen + 2) & "2" & Mid(strTemp, intSerialNumLen + 4)
    
    '返回重写了状态值和时间戳的记录
    WriteTimeMark = Mid(strTemp, 1, intStatusLen + intTimeMarkLen + 2) & str1
    
End Function

'播放语音字符串子过程
Public Sub SpeakString(strInput As String)
    
End Sub

'取得一条叫号记录中序号
Public Function GetRecordStrSerialNum(strTemp As String) As String
    GetRecordStrSerialNum = CStr(CInt(Mid(strTemp, 2, intSerialNumLen)))
End Function

'取得一条叫号记录中状态值
Public Function GetRecordStatus(strTemp As String) As Integer
    GetRecordStatus = CInt(Mid(strTemp, intSerialNumLen + 3, 1))
End Function

'取得一条叫号记录中叫号时间值
Public Function GetRecordTime(strTemp As String) As String
    GetRecordTime = Mid(strTemp, intSerialNumLen + intStatusLen + 4, 6)
End Function

'取得当前第一个空闲的护士台序号
Public Function GetSpareNurse() As Integer
    Dim i As Integer
    For i = 1 To gNurseNum
        If gNurseStatus(i) = 0 Then
            GetSpareNurse = i
            Exit Function
        End If
    Next i
    GetSpareNurse = 0
End Function

'创建队列文件
Private Sub CreateQueuefile(QueueFileTemp As String)

   Dim FileNumber
   Dim strDate As String
   
   FileNumber = FreeFile   ' 取得未使用的文件号。
   Open gQueueFileName For Output As #FileNumber   ' 创建文件名。
   strDate = NeatenDate()
   Write #FileNumber, "***" & NeatenDate() & "***" '    输出文本至文件中
   Close #FileNumber   ' 关闭文件。

End Sub


'读取队列文件
Public Function ReadQueue(strQueueFile As String) As String
    Dim fso As New FileSystemObject
    Dim txtfile, fil1 As File
    Dim ts As TextStream
    Dim strTemp As String
    
    Set fil1 = fso.GetFile(gQueueFileName)
    ' 读取文件的内容。
    Set ts = fil1.OpenAsTextStream(ForReading)
    strTemp = ts.ReadLine
    '去除文件头和尾的两个引号
    ReadQueue = Mid(strTemp, 2, Len(strTemp) - 2)
    ts.Close

End Function


'将日期字符串整形为"20070701"这样的形式
Public Function NeatenDate() As String
    Dim strMonth, strDay As String

    strMonth = Month(Date)
    If Len(strMonth) = 1 Then
        strMonth = "0" & strMonth
    End If
    
    strDay = Day(Date)
    If Len(strDay) = 1 Then
        strDay = "0" & strDay
    End If
    
    NeatenDate = Year(Date) & strMonth & strDay
End Function

'取得当前队列中排队记录的条数
Public Function GetRecordNum() As Long
    If Len(gstrQueue) > QueueFileDateLen Then
        GetRecordNum = CLng((Len(gstrQueue) - QueueFileDateLen) / intRecordLen)
    Else
        GetRecordNum = 0
    End If
End Function

'取得第intN条排队记录
Public Function GetQueueRecord(intN As Integer) As String
    GetQueueRecord = Mid(gstrQueue, QueueFileDateLen + 1 + (intN - 1) * intRecordLen, intRecordLen)
End Function

'等待过去多长时间，以毫秒计
Public Sub TimeDelay(DT As Long)
    Dim TT As Long
    TT = GetTickCount()
    Do
        DoEvents
        DoEvents
        If GetTickCount - TT < 0 Then TT = GetTickCount
'        If gblnCancel = True Then Exit Do '用户单击了取消
    Loop Until GetTickCount - TT >= DT
End Sub