frmdata.frm

一个完整的非接触IC卡会员管理系统

                    MSComm1.OutBufferCount = 0 '清除发送缓冲区
                    MSComm1.InBufferCount = 0 '清除接收缓冲区
                    MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
                    Lab2.Refresh
                    File1.Refresh
                    Lab2.Caption = "采集完毕"
                    
                End If
            
            Case "8D"  '准备名单，对名单分组，每组10个，不足用FF代替
                  If Mid(sttxt1, 7, 2) = "00" Then
                        sttxt1 = ""
                        Lab2.Caption = "版本一致，不需更新！"
                        Exit Sub
                  End If
                  MSComm1.OutBufferCount = 0 '清除发送缓冲区
                  MSComm1.InBufferCount = 0 '清除接收缓冲区
'                  MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
                  sttxt1 = ""
                  stSend(0) = &HBA '发第一组名单
                  stSend(1) = &H23
                  stSend(2) = &H8E
                  stSend(3) = &H0
                  stSend(4) = &H0
                  stSend(5) = &H1E
                  pssql = "select * from blk  where id=1"
                  Set rs = GetRecordset(maSys_db, pssql)
                  If rs.RecordCount = 0 Then Lab2.Caption = "更新完毕！": Exit Sub '没有名单
                  stList = rs.Fields("idlist")
                  listn = 1
                  mm = Len(stList)
                  mmm = mm / 2
                  stSend(1) = mmm + 5
                  stSend(5) = mmm
                  For n = 0 To mmm - 1
                     stSend(n + 6) = "&H" + Mid(stList, listn, 2)
                     listn = listn + 2
                  Next n
                  stSend(mmm + 6) = 0
                  For n = 0 To mmm + 5
                      stSend(mmm + 6) = stSend(mmm + 6) Xor stSend(n)
                  Next
                  sendn = 2
                  stList = ""
                  For n = 0 To mmm + 6
                      stList = stList + Right("00" + hex(stSend(n)), 2)
                  Next n
                  sendnn = 10
                  DSend (stList)
'                  MSComm1.Output = stSend '发送数据
                  
            Case "8E" '发送名单,从第2条名单组开始发
                If Mid(sttxt1, 5, 2) = "8E" Then
                    MSComm1.OutBufferCount = 0 '清除发送缓冲区
                    MSComm1.InBufferCount = 0 '清除接收缓冲区
'                    MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
                    sttxt1 = ""
                    stSend(0) = &HBA
                    stSend(1) = &H23
                    stSend(2) = &H8E
                    sttxt = hex(CDbl(sendnn))
                    sttxt = Right("0000" + sttxt, 4)
                    stSend(3) = "&H" + Mid(sttxt, 1, 2) '名单个数
                    stSend(4) = "&H" + Mid(sttxt, 3, 2)
                    stSend(5) = &H1E
                    pssql = "select * from blk  where id=" & sendn
                    Set rs = GetRecordset(maSys_db, pssql)
                    If rs.RecordCount = 0 Then
                        stSend(0) = &HBA
                        stSend(1) = &H5
                        stSend(2) = &H8E
                        stSend(3) = &H0
                        stSend(4) = &H0
                        stSend(5) = &H0
                        stSend(6) = &H31
                        stList = ""
                        For n = 0 To 6
                            stList = stList + Right("00" + hex(stSend(n)), 2)
                        Next n
                        If sendEnd = 2 Then
                             Exit Sub
                        Else
                            sendEnd = sendEnd + 1
                        End If
                        DSend (stList)
            
'                        DSend (stList)
'                        MSComm1.Output = stSend '发送数据
                        Lab2.Caption = "更新完毕！"
                       
                        sttxt1 = ""
                        Exit Sub '没有名单
                    End If
                    stList = rs.Fields("idlist")
                    listn = 1
                    mm = Len(stList)
                    mmm = mm / 2
                    stSend(1) = mmm + 5
                    stSend(5) = mmm
                    For n = 0 To mmm - 1
                       stSend(n + 6) = "&H" + Mid(stList, listn, 2)
                       listn = listn + 2
                    Next n
                    stSend(mmm + 6) = 0
                    For n = 0 To mmm + 5
                        stSend(mmm + 6) = stSend(mmm + 6) Xor stSend(n)
                    Next
                    sendn = sendn + 1
                    sendnn = sendnn + 10
                    stList = ""
                    For n = 0 To mmm + 6
                        stList = stList + Right("00" + hex(stSend(n)), 2)
                    Next n
                    DSend (stList)
'                    MSComm1.Output = stSend '发送数据
                Else
                    sttxt1 = ""
                    MSComm1.OutBufferCount = 0 '清除发送缓冲区
                    MSComm1.InBufferCount = 0 '清除接收缓冲区
                    MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
'                    MSComm1.Output = stSend '发送数据
                    DSend (stList)
                End If
           End Select
        End If
    End Select
    End With
End Sub
Private Function Hex2(c As String) As String
    Hex2 = hex(c)
    If Len(Hex2) < 2 Then
        Hex2 = "0" & Hex2
    End If
End Function
Public Function isProperDate(strDate As String)
   Dim strTmp As String
  '将输入的日期转换成IsDate（）所接受的日期格式
   strTmp = Mid(strDate, 1, 4) + "," + Mid(strDate, 5, 2) + "," + Mid(strDate, 7, 2)
   getProperDate = IsDate(strTmp)
End Function

Private Sub Command2_Click()
Dim i As Integer
Dim n As Integer
Dim m As Integer
Dim psRecord As String
Dim pstemp As String
Dim psPathFile As String
Dim psBFPathFile As String
Dim rs As New ADODB.Recordset
Dim rsdb As New ADODB.Recordset

Dim psCardID As String
Dim psCardIDL As Long
Dim psCardNO As String
Dim psName As String
Dim psDept As String
Dim psReadNO As String '
Dim psDate As String
Dim pdConsume_dateB As String
Dim pbIn(3) As Byte
Dim L As Long
Dim TEST As Boolean
If File1.ListCount = 0 Then Exit Sub
TEST = False
If TEST Then
    pstemp = "delete  from linkdatabuffer "
    maSys_db.Execute pstemp, dbFailOnError
End If
Lab1.Caption = "请等待..."
Lab1.Refresh
Do While i < File1.ListCount
    File1.ListIndex = i
    psPathFile = App.Path & "\" & File1.FileName
    psBFPathFile = App.Path & "\bakup\" & File1.FileName
    Open psPathFile For Input Access Read Lock Read Write As #1
    Do While Not EOF(1)
        Input #1, psRecord
        
        If Option1.value = True And Mid(File1.FileName, 1, 4) = "POS" Then
            m = 1
            For n = 1 To 10 '1 27 53 79 105 131 157 183 209 235
                            '050000 0001 01 01 070215230532
                pstemp = Mid(psRecord, m, 26)
                m = m + 26
                If Right(pstemp, 12) <> "000000000000" Then
                    psCardID = Mid(pstemp, 1, 6)
                    pbIn(0) = "&h" + Mid(psCardID, 1, 2)
                    pbIn(1) = "&h" + Mid(psCardID, 3, 2)
                    pbIn(2) = "&h" + Mid(psCardID, 5, 2)
                    
                    If (pbIn(0) + pbIn(1) * L + pbIn(2) * L * L) < 2147483647 Then
                        psCardIDL = pbIn(0) + pbIn(1) * L + pbIn(2) * L * L
                    Else
                        psCardIDL = 0
                    End If
                    psCardID = Format(psCardIDL, "000000")
                    
                    psReadNO = Mid(pstemp, 7, 4)
                    psDate = "20" + Mid(pstemp, 15, 2) & "-" & Mid(pstemp, 17, 2) & "-" & Mid(pstemp, 19, 2) & " " & Mid(pstemp, 21, 2) & ":" & Mid(pstemp, 23, 2) & ":" & Mid(pstemp, 25, 2)
                    If Not IsDate(psDate) Then
                        If pdConsume_dateB <> "" Then
                            psDate = pdConsume_dateB
                        Else
                            psDate = "2000-01-01 01:01:01"
                        End If
                    End If
                    pdConsume_dateB = psDate
                    
                    Set rs = GetRecordset(maSys_db, "select *  from full_userdict where userid='" & Trim(psCardID) & "'")
                    If Not (rs.EOF And rs.BOF) Then
                        psCardNO = rs.Fields("m1cardid") '物理卡号
                        psName = rs.Fields("username") '持卡人
                        psDept = rs.Fields("dept_name") '部门
                        
                        Set rs = GetRecordset(maSys_db, "select *  from linkdatabuffer where m1cardno='" & psCardID & "' and  m1date='" & psDate & "'")
                        If Not (rs.EOF And rs.BOF) Then
                        
                        Else
                            rsdb.Open "select * from linkdatabuffer where 1>2", maSys_db, 3, 3
                            rsdb.AddNew
                            rsdb.Fields("readerno") = psReadNO
                            rsdb.Fields("m1cardid") = psCardNO
                            rsdb.Fields("m1cardno") = psCardID
                            rsdb.Fields("m1name") = psName
                            rsdb.Fields("m1date") = psDate
                            rsdb.Fields("dept_name") = psDept
                            rsdb.Update
                            rsdb.Close
                        End If
                    Else
                        '找不到该卡号记录信息，记录不做处理
                    End If
                End If
            Next n
        End If
        
        If Option2.value = True And Mid(File1.FileName, 1, 4) = "LINK" Then '联机采集时文件名和数据格式不一样
        'BD168F09 050000 0001 0101 07041014071000000000000039
            pbIn(0) = "&h" + Mid(psRecord, 9, 2)
            pbIn(1) = "&h" + Mid(psRecord, 11, 2)
            pbIn(2) = "&h" + Mid(psRecord, 13, 2)
            If (pbIn(0) + pbIn(1) * L + pbIn(2) * L * L) < 2147483647 Then
                psCardIDL = pbIn(0) + pbIn(1) * L + pbIn(2) * L * L
            Else
                psCardIDL = 0
            End If
            psCardID = Format(psCardIDL, "000000") '卡号
            
            psDate = "20" + Mid(psRecord, 23, 2) & "-" & Mid(psRecord, 25, 2) & "-" & Mid(psRecord, 27, 2) & " " & Mid(psRecord, 29, 2) & ":" & Mid(psRecord, 31, 2) & ":" & Mid(psRecord, 33, 2)
            If Not IsDate(psDate) Then
                If pdConsume_dateB <> "" Then
                    psDate = pdConsume_dateB
                Else
                    psDate = "2000-01-01 01:01:01"
                End If
            End If
            pdConsume_dateB = psDate '时间
            
            psReadNO = Mid(psRecord, 15, 4) '设备号
            Set rs = GetRecordset(maSys_db, "select *  from full_userdict where userid='" & Trim(psCardID) & "'")
            If Not (rs.EOF And rs.BOF) Then
                psCardNO = rs.Fields("m1cardid") '物理卡号
                psName = rs.Fields("username") '持卡人
                psDept = rs.Fields("dept_name") '部门
                Set rs = GetRecordset(maSys_db, "select *  from linkdatabuffer where m1cardno='" & psCardID & "' and  m1date='" & psDate & "'")
                If Not (rs.EOF And rs.BOF) Then
                
                Else
                    rsdb.Open "select * from linkdatabuffer where 1>2", maSys_db, 3, 3
                    rsdb.AddNew
                    rsdb.Fields("readerno") = psReadNO
                    rsdb.Fields("m1cardid") = psCardNO
                    rsdb.Fields("m1cardno") = psCardID
                    rsdb.Fields("m1name") = psName
                    rsdb.Fields("m1date") = psDate
                    rsdb.Fields("dept_name") = psDept
                    rsdb.Update
                    rsdb.Close
                End If
            Else
                '找不到该卡号记录信息，记录不做处理
            End If
        End If
    Loop
    
    Close #1
    
    FileCopy psPathFile, psBFPathFile
    Kill psPathFile
    i = i + 1
    Lab1.Caption = "已完成  " & CStr(Int(i / File1.ListCount * 100)) & "%"
    Lab1.Refresh
Loop
File1.Refresh
End Sub

Private Sub Command3_Click()
Unload Me
End Sub

Private Sub Form_Load()
    On Error GoTo Err1
    With MSComm1
        .CommPort = comPort '选择串口COM1
        .Settings = comSet '设置通信口参数
        .InBufferSize = 1024 '接收缓冲区大小
        .OutBufferSize = 1024 '发送缓冲区大小
        .InputMode = comInputModeBinary '设置接收数据模式为二进制形式
        .InputLen = 0 '设置Input从接收缓冲读取全部数据
        .RThreshold = 1 '设置引发OnComm事件的字节长度
        .InBufferCount = 0 '清除接收缓冲区
        .OutBufferCount = 0 '清除发送缓冲区
   End With
   
   
   If MSComm1.PortOpen = False Then
       MSComm1.CommPort = 1
       MSComm1.Settings = comSet
       MSComm1.PortOpen = True '打开通信口
    
   End If
    
Exit Sub
Err1:
   Select Case err.Number   '串口被其它程序打开的出错提示
     Case 8005
      MsgBox "串口打开错误,可能串口被其它程序打开,请关闭其它程序再打开.", vbInformation
     Case Else
      MsgBox "程序出错:" & "出错代码. " & err.Number & ": 出错提示信息: " & err.Description, vbInformation
   End Select
End Sub

Private Sub Form_Unload(Cancel As Integer)

If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False '关闭通信口
End If
'If MSComm1.PortOpen = True Then
'    MsgBox "关闭程序出错,请关闭串口后再关闭本程序.", vbInformation
'    Cancel = 1
'    End If
End Sub