101.frm

这是我给公司编写的自己使用的一个考勤系统

  MSComm1.Output = aa()
  aa(0) = CToHex("0" + Mid(Format(Now, "yy mm dd w hh:mm:ss"), 10, 1))
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = CToHex(Mid(Format(Now, "yy mm dd w hh:mm:ss"), 4, 2))
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = CToHex(Mid(Format(Now, "yy mm dd w hh:mm:ss"), 7, 2))
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = CToHex(Mid(Format(Now, "yy mm dd w hh:mm:ss"), 12, 2))
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = CToHex(Mid(Format(Now, "yy mm dd w hh:mm:ss"), 15, 2))
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = CToHex(Mid(Format(Now, "yy mm dd w hh:mm:ss"), 18, 2))
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  
  MSComm1.Output = jiaoyan()
 
End Sub
Private Sub Command5_Click()
'通讯测试
  If (MSComm1.PortOpen) Then
      MSComm1.PortOpen = False
  End If
initchk1 MSComm1, intPort
  MSComm1.OutBufferCount = 0
  aa(0) = 170
  MSComm1.Output = aa()
  jiaoyan(0) = aa(0)
  aa(0) = 255
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  
  aa(0) = Val(Text2.Text)
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 3
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 166
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = CToHex(Text4.Text)
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = CToHex(Text5.Text)
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  
  MSComm1.Output = jiaoyan()
End Sub

Private Sub Command6_Click()
    Dim start, ends
    strReadAllRecordError = ""
    strReadOver = "false"
    
    int1 = 1
    'For int1 = 1 To 5
    Do While True
        strReadOver = "false"
        'delay (5)
        ReadAll int1
        
        start = timeGetTime
        ends = start
        'delay (5)
        Call ReadProcess
        
        Do While strReadOver = "false" '没有发回数据等待
            If (ends - start) Mod 5 Then
                DoEvents
            End If

            ends = timeGetTime
            If (ends - start) > 300 Then
                'Label4.Caption = int1 & "号机未连接"
                GoTo err1
            End If
        Loop
err1:
        If blstop Then
            blstop = False
            'lbldisplay.Caption = "实时读取完毕"
            Exit Do
        End If
        'If int1 = 5 Then
        '    int1 = 0
        'End If
    'Next int1
    Loop
    lbldisplay.Caption = "停止读取"
    Exit Sub
err2:
    lbldisplay.Caption = "Error"
    
End Sub

Private Sub Command7_Click()
'删除记录
  If (MSComm1.PortOpen) Then
      MSComm1.PortOpen = False
  End If
initchk1 MSComm1, intPort
  MSComm1.OutBufferCount = 0
  aa(0) = 170
  MSComm1.Output = aa()
  jiaoyan(0) = aa(0)
  aa(0) = 255
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  
  aa(0) = Val(Text2.Text)
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 1
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 163
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  MSComm1.Output = jiaoyan()

End Sub

Private Sub Command8_Click()
   Text1.Text = ""
End Sub

Private Sub Form_Load()
'MSComm1.CommPort = 1 '串口号，
'MSComm1.Settings = "9600,N,8,1" '串口的属性
'MSComm1.InputLen = 0 '接收缓冲区的大小
'MSComm1.InputMode = comInputModeBinary '二进制接受方式
'MSComm1.PortOpen = True '打开通信串口
    Dim strconn As String
    Dim m As Integer
    If (chuanopen) Then
     i = MsgBox("数据已经接受，如果想再次接受数据，请先进行“考勤整理”关闭系统重新启动", 0 + 48, "警告")
     If (i = 1) Then
       
       Exit Sub
        End If
        End If
   strconn = "Provider=Microsoft.Jet.OLEDB.4.0;Persist " & _
   "Security Info=False;Data Source=" & App.Path & "\db2.mdb"
   conn.Open strconn
   chuanopen = True
Frame1.Visible = True
intPort = 1
kahaoshu = 0
aaa:  End Sub

Private Sub MSComm1_OnComm() '串口中断
'On Error Resume Next
Dim Xbyte As Long
Dim j As Long
Dim InByte()  As Byte '存储数据的缓冲区'定义一个二进制指针放接收到的数据
Dim inbyte2() As Byte

Select Case MSComm1.CommEvent '选择事件
Case comEvReceive '接收到字符
        'MSComm1.InputLen = 0
        'Xbyte = MSComm1.InBufferCount
        'Label3.Caption = Xbyte
        
        InByte() = MSComm1.Input '数据转移到指针
        For j = 0 To UBound(InByte)
            inData = inData & DecToHex(CDec(InByte(j))) '转换成十六进制 显示用
        Next j
        
    
    '  If MSComm1.InBufferCount Then
    '      inbyte2() = MSComm1.Input
    '
    '     For j = 0 To UBound(InByte)
    '         inData = inData & DecToHex(CDec(InByte(j))) '转换成十六进制 显示用
    '     Next j
    '  End If
    
    Text1.SelText = inData '将刚收到的字符串显示出来
    Text15.SelText = inData '将刚收到的字符串显示出来
    inData = ""
        
      'BB  FF  01  01  77  33
      'BB  FF  01  13  00  22  EC  FA  04  04  12  01  14  12  48  00  20  0B  00  20  00  FC  00  C8
''    Text14.SelStart = Len(Text14.Text) '光标置后
    If strOperateType = "read" Then '第一次响应: BB FF 01 0C 00 22 E5 15
        'int_1=int_1+1
        ReadProcess '第二次响应：04 05 09 30 13 35 45 00 C0
    ElseIf strOperateType = "readnext" Then
        ReadNextProcess
    End If
    
Case comEventRxOver '接收缓冲区满的处理
   MsgBox "接收缓冲区满了！" '发出警告
End Select
End Sub
Function DecToHex(DecNumber As Integer) As String '转换成十六进制字符串
        If DecNumber <= 15 Then
            DecToHex = "  0" & Hex(DecNumber)
        Else: DecToHex = "  " & Hex(DecNumber)
        End If
End Function
Function CToHex(DecNumber As String) As Integer '字符串转换成十六进制数
Dim S1 As String
Dim s, S2 As Byte
If Len(DecNumber) = 2 Then
  S1 = Mid(DecNumber, 1, 1)
  Select Case S1
        Case "0" To "9"
        s = Asc(S1) - 48
        Case "A" To "F"
        s = Asc(S1) - 55
        Case "a" To "f"
        s = Asc(S1) - 87
        Case Else
        s = 0
  End Select
  s = s * 16
  S1 = Mid(DecNumber, 2, 1)
  Select Case S1
        Case "0" To "9"
        S2 = Asc(S1) - 48
        Case "A" To "F"
        S2 = Asc(S1) - 55
        Case "a" To "f"
        S2 = Asc(S1) - 87
        Case Else
        S2 = 0
  End Select
  
  CToHex = s + S2
Else
  CToHex = 0
End If
        
End Function
Private Sub Form_Unload(Cancel As Integer) '退出时关闭端口

    If (MSComm1.PortOpen) Then
        MSComm1.PortOpen = False
    End If
    
End Sub
'========================================================================
Public Function ReadAll(intmc As Integer) As Integer
    lbldisplay.Caption = "正在读取数据..."

    strOperateType = "read"
    Text15.Text = ""

    If (MSComm1.PortOpen) Then
        MSComm1.PortOpen = False
    End If
    initchkRead MSComm1, intPort

  MSComm1.OutBufferCount = 0
  aa(0) = 170
  MSComm1.Output = aa()
  jiaoyan(0) = aa(0)
  aa(0) = 255
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()

  aa(0) = Val(intmc)
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 1
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 161
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  MSComm1.Output = jiaoyan()
End Function
Public Function ReadNext(intmc As Integer) As Integer
    '读指针下移一条
    strOperateType = "readnext"
    Text15.Text = ""
    lbldisplay.Caption = "正在读下一条..."
    If (MSComm1.PortOpen) Then
        MSComm1.PortOpen = False
    End If
    initchk1 MSComm1, intPort

  MSComm1.OutBufferCount = 0
  aa(0) = 170
  MSComm1.Output = aa()
  jiaoyan(0) = aa(0)
  aa(0) = 255
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()

  aa(0) = Val(intmc)
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 1
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 162
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  MSComm1.Output = jiaoyan()

End Function
Private Sub ReadProcess()
    lbldisplay.Caption = "正在处理数据..."
        '==============================================================================
                '  BB  FF  01  0B  00  0D  92  09  04  03  11  09  15  06  38  EC
              '================================================================================
            '处理读到的数据
                If Not JYdata(MSComm1) Then
                    strReadNext = "Error"
                    Exit Sub
                End If
                
                Dim i As Integer
                For i = 0 To 23
                    Text15.Text = Text15.Text & DecToHex(CDec(rebuf(i)))
                Next i

                'text14.Text = Text14.Text & Text15.Text & Chr(13) & Chr(10)
                'If Mid(Text15.Text, 15, 6) = "01  77" Then '没有用户刷卡  BB  FF  01  01  77  33
                
                If Len(Text15.Text) <> 96 Then
                    Text14.Text = Text14.Text & Chr(13) & Chr(10) & int1 & "号机:" & "无用户刷卡"
                    Text14.SelStart = Len(Text14.Text) '光标置后
                    Exit Sub
                End If
                
                Text14.Text = Text14.Text & Chr(13) & Chr(10) & int1 & "号机刷卡信息:" & Text15.Text & Chr(13) & Chr(10)
                Text14.SelStart = Len(Text14.Text) '光标置后
                Beep '刷卡响两声
                If Len(Text15.Text) = 96 Then
                    strall = Text15.Text
                     kahaoshu = kahaoshu + 1
                    Text16.Text = LTrim(Str(CDec(rebuf(5)) * 2 ^ 16 + (rebuf(6) * 2 ^ 8) + rebuf(7)))
                    kahaochuan(kahaoshu) = LTrim(Str(CDec(rebuf(5)) * 2 ^ 16 + (rebuf(6) * 2 ^ 8) + rebuf(7)))
                     Text17.Text = LTrim(Mid(Text15.Text, 33, 28))
                    Call process
                End If
        '================================================================================
            strReadNext = "Busy"
            delay (5) '最新加上去的代码,防止出错
            ReadNext (int1)
wait:
             'delay (5)
             start = timeGetTime
             ends = start
            Do While strReadNext = "Busy" '没有发回数据等待
                   If (ends - start) Mod 5 Then
                       DoEvents
                   End If

                  ends = timeGetTime
                  If (ends - start) > 300 Then
                        GoTo err1
                  End If

             Loop

             'delay (5)
             If strReadNext = "Empty" Then
                 strReadOver = "true"
                 lbldisplay.Caption = "读取完毕"
                 Exit Sub
             ElseIf strReadNext = "Error" Then
                 Text15.SelText = ""
                 strReadNext = "busy"
                 ReadNext (int1)
                 GoTo wait
             ElseIf strReadNext = "Ok" Then
'                 If strOneORAll = "one" Then
'                     Text15.Text = ""
'                     read
'                 Else
'                     Text15.Text = ""
'                    ReadAll (int1)
'                     delay (10)
'                 End If
             End If
        '================================================================================================
    Exit Sub

err1:
    lbldisplay.Caption = "读取记录超时出错!"
    Text1.Text = ""
End Sub
Private Sub ReadNextProcess()
    ' BB FF 01 01 55 11
    Dim str1, str2 As String
    str1 = Mid(Text15.Text, 11, 2)
    str2 = Mid(Text15.Text, 14, 2)
    If str2 = "77" Then
        strReadNext = "Empty"
        lbldisplay.Caption = "卡号库己没有记录，或己被清空!1"
        Exit Sub
    ElseIf str2 = "55" Then
        strReadNext = "Ok"
    Else 'If str1 = "01" And str2 = "33" Then
        strReadNext = "Error"
    End If
End Sub
Function initchk1(urt1 As MSComm, i As Byte) As Boolean
 On Error GoTo err1
    urt1.CommPort = i '串口号
    urt1.Settings = "9600,N,8,1" '串口的属性
    urt1.InputLen = 0 '接收缓冲区的大小
    urt1.InputMode = comInputModeBinary '二进制接受方式
    urt1.RThreshold = 1 '每7个字节响应消息
    urt1.PortOpen = True '打开通信串口
    initchk1 = True
Exit Function
err1:
  initchk1 = False

  MsgBox "初始串口" + CStr(i) + "出错！", vbInformation, ""

End Function
'BB  FF  01  13  00  B8  0F  45  04  03  12  28  13  59  01  00  94  00  00  93  6E  01  00  BA
Function initchk2(urt1 As MSComm, i As Byte) As Boolean
 On Error GoTo err1
    urt1.CommPort = i '串口号
    urt1.Settings = "9600,N,8,1" '串口的属性
    urt1.InputLen = 0 '接收缓冲区的大小
    urt1.InputMode = comInputModeBinary '二进制接受方式
    'urt1.RThreshold = 24  '每7个字节响应消息
    urt1.PortOpen = True '打开通信串口
    initchk2 = True
Exit Function
err1:
  initchk2 = False

  MsgBox "初始串口" + CStr(i) + "出错！", vbInformation, ""

End Function
Private Sub read()
    strOperateType = "read"
    Text15.Text = ""
    
    If (MSComm1.PortOpen) Then
        MSComm1.PortOpen = False
    End If
    initchk1 MSComm1, intPort

  MSComm1.OutBufferCount = 0
  aa(0) = 170
  MSComm1.Output = aa()
  jiaoyan(0) = aa(0)
  aa(0) = 255
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()

  aa(0) = Val(int1)
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 1
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  aa(0) = 161
  jiaoyan(0) = jiaoyan(0) Xor aa(0)
  MSComm1.Output = aa()
  MSComm1.Output = jiaoyan()
End Sub
Private Sub process()
    Dim strSql As String
    Dim rsfind As New ADODB.Recordset
    strSql = "select * from 刷卡登记"
    rsfind.CursorLocation = adUseClient
    rsfind.Open strSql, conn, adOpenDynamic, adLockPessimistic
    rsfind.AddNew
    rsfind.Fields(0) = Text16.Text
     rsfind.Fields(1) = Text17.Text
    rsfind.Update
    rsfind.Close
End Sub
Function JYdata(MSComm1 As MSComm) As Boolean
   star = timeGetTime
   ends = star
  Do While MSComm1.InBufferCount < 24 '没有发回数据等待
    DoEvents
     ends = timeGetTime
     If (ends - star) > 250 Then
       GoTo err1
       End If
       
 Loop
   
   MSComm1.InputLen = 1
   
 
   Do While MSComm1.InBufferCount > 0 '发回数据读取
       ReDim Preserve rebuf(i + 1)
       rebuf(i) = MSComm1.Input(0)
       
         If i = 0 Then
         JY = rebuf(i)
        Else
           If i < 23 Then
            JY = JY Xor rebuf(i)
          End If
        End If
'       If i = 1 And rebuf(i) = &H1 Then
'         GoTo err1
'        End If
        
       i = i + 1
   
         
   Loop
       If i < 22 Then
         GoTo err1 '如果读取数据数目不够,则重新读取
      End If
      
readend:
'    Label4.Caption = JY
'    Text14.Text = rebuf(23)
   If JY = rebuf(23) Then '如果读取正确
      JYdata = True
   Else '否则报警
      GoTo err1
   End If
    
   Exit Function
err1:
    JYdata = False
    Text14.Text = Text14.Text & Chr(13) & Chr(10) & int1 & "号机:" & "无用户刷卡"
    Text14.SelStart = Len(Text14.Text) '光标置后
End Function