frmdata.frm

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

Dim stSend(100) As Byte
Dim stSendTmp(100) As Byte
Dim FullFileId As Long
Dim stMaxID As String
Dim stMinId As String
Dim stCount As String
Dim listn As Integer
Dim sendn As Integer
Dim sendnn As Integer '名单包的起始名单位置
Dim str1 As String
Dim mm As Integer
Dim mmm As Integer
Dim sendEnd As Integer

Private Sub Command1_Click() '操作采集器
List1.Clear
Dim pssql As String
Command1.Enabled = False
If Option1.value = 1 Then
    Lab1.Caption = ""
    If Check1.value = 1 Then '校时
    
    End If
        
    If Check2.value = 1 Then '下载有效名单
    Lab1.Caption = "正在组织有效名单..."
    pssql = "select * from Full_UserDict  where m1cardstate='启用' order by m1cardid"
    Set rs = GetRecordset(maSys_db, pssql)
    stList = ""
    stList = Format(CStr(rs.RecordCount), "00000000")
    Do While Not rs.EOF
        stList = stList & rs!m1cardid
        rs.MoveNext
    Loop
    rs.Close
    Lab1.Caption = "正在导入有效名单..."
    End If
    
    If Check3.value = 1 Then '下载记录
        psTempPathFile1 = App.Path + "\POS" + Format(Now, "yyyymmddhhmmss") + ".txt"
        Open psTempPathFile1 For Output As #2
        Lab2.Caption = "请等待..."
        Lab2.Refresh
        stList = "BD028813"
        n = 0
        
        DSend (stList)
    End If
    
    If Check4.value = 1 Then '删除采集器记录
    
    End If
    Lab1.Caption = ""
Else '操作门禁考勤机
    psRecordID = 1
    stList = ""
    
    Dim stimes As String
     
    stSend(0) = &HBA
    stSend(1) = &H4
    stSend(2) = &H8F
    
    stimes = Right("0000" + hex(CDbl(psRecordID)), 4)
    stSend(3) = "&H" + Mid(stimes, 1, 2)
    stSend(4) = "&H" + Mid(stimes, 3, 2)
    stSend(5) = &H0
    
    For n = 0 To 4
        stSend(5) = stSend(5) Xor stSend(n)
    Next n
    
    stList = ""
    For n = 0 To 5
        stList = stList + Right("00" + hex(stSend(n)), 2)
    Next n
    
    '取文件ID
    FullFileId = Val(GetRegKey(HKEY_CURRENT_USER, "FullFile", "OrderId", ""))
    If FullFileId = 0 Then
        FullFileId = 1
        SaveRegKey HKEY_CURRENT_USER, "FullFile", "OrderId", str(FullFileId)
    Else
        FullFileId = FullFileId + 1
        SaveRegKey HKEY_CURRENT_USER, "FullFile", "OrderId", str(FullFileId)
    End If
    
    psTempPathFile1 = App.Path + "\LINK" + Format(Now, "yyyymmddhhmmss") + Format(FullFileId, "00000000") + ".txt"
    On Error GoTo Err1
    Open psTempPathFile1 For Output As #3
    DSend (stList)
End If
Exit Sub

Err1:
Close #3
Command1.Enabled = True
Err2:
    
End Sub
'数据发送函数
Private Sub DSend(DataSend As String)
    
    Dim i As Integer
    Dim k As Integer
      
    MSComm1.OutBufferCount = 0 '清除发送缓冲区
    MSComm1.InBufferCount = 0 '清除接收缓冲区
    MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
     
    i = (Len(DataSend)) / 2
    ReDim DataHex((i - 1)) As Byte
    For k = 0 To (i - 1)
    DataHex(k) = CByte("&H" & Right((Left(DataSend, (k + 1) * 2)), 2)) 'Asc(Right((Left(DataSend, k + 1)), 1)) '
    Next k
    
    'DataHex(0) = &H39
On Error GoTo Err2
    MSComm1.Output = DataHex '发送数据
'    List1.Clear
'    rsSend = 1
      Exit Sub
Err2:
    Select Case err.Number   '串口没有打开的出错提示
       Case comPortNotOpen
        MsgBox err.Description, vbInformation
       Case Else
        MsgBox "程序出错:" & "出错代码. " & err.Number & ": 出错提示信息: " & err.Description, vbInformation
    End Select
End Sub

Private Sub Command4_Click()
    If Option1.value = True Then
        stList = "BD024413"
        DSend (stList)
    End If
End Sub

Private Sub Command5_Click()
If Check2.value = 1 Then
    Lab2.Caption = "开始下载名单..."
    maSys_db.Execute "delete from blk"
    psRecordID = 1 '传第1组名单
    listn = 1
    If Option3.value = True Then
    pssql = "select * from Full_UserDict  where m1cardstate='启用' order by userid"
    Else
    pssql = "select * from Full_UserDict  where m1cardstate='挂失' order by userid"
    End If
    Set rs = GetRecordset(maSys_db, pssql)
    If rs.RecordCount = 0 Then Lab2.Caption = "更新完毕！": Exit Sub '没有名单
    stCount = rs.RecordCount
    rs.MoveFirst
    stMaxID = rs.Fields("userid")
    rs.MoveLast
    stMinId = rs.Fields("userid")
    rs.MoveFirst
    stList = ""
    Do While Not rs.EOF
        str1 = hex(CDbl(Val(rs!userid)))
        If Len(str1) <= 6 Then
            Do While Not Len(str1) = 6
                str1 = "0" + str1
            Loop
        End If
        str1 = Mid(str1, 5, 2) + Mid(str1, 3, 2) + Mid(str1, 1, 2)
        stList = stList & str1
        If Len(stList) = 60 Then
            maSys_db.Execute "insert into blk(id,idlist) values(" & listn & ",'" & Trim(stList) & "')"
            listn = listn + 1
            stList = ""
        End If
        rs.MoveNext
    Loop
    rs.Close
    If Len(stList) <> 0 Then
         maSys_db.Execute "insert into blk(id,idlist) values(" & listn & ",'" & Trim(stList) & "')"
    End If
    stSend(0) = &HBA
    stSend(1) = &HC
    stSend(2) = &H8D
    stSend(3) = &H2 '版本
    stSend(4) = &H0
    sttxt = hex(CDbl(stCount))
    sttxt = Right("0000" + sttxt, 4)
    stSend(5) = "&H" + Mid(sttxt, 3, 2) '数量
    stSend(6) = "&H" + Mid(sttxt, 1, 2)
    stSend(3) = stSend(5) '版本
    stSend(4) = stSend(6)
    sttxt = hex(CDbl(stMaxID))
    sttxt = Right("000000" + sttxt, 6)
    stSend(7) = "&H" + Mid(sttxt, 5, 2) '最小号
    stSend(8) = "&H" + Mid(sttxt, 3, 2)
    stSend(9) = "&H" + Mid(sttxt, 1, 2)
    sttxt = hex(CDbl(stMinId))
    sttxt = Right("000000" + sttxt, 6)
    stSend(10) = "&H" + Mid(sttxt, 5, 2) '最大号stMinId
    stSend(11) = "&H" + Mid(sttxt, 3, 2)
    stSend(12) = "&H" + Mid(sttxt, 1, 2)
    stSend(13) = &H0
    For n = 0 To 12
        stSend(13) = stSend(13) Xor stSend(n)
    Next n
    
    stList = ""
    For n = 0 To 13
        stList = stList + Right("00" + hex(stSend(n)), 2)
    Next n
    sendEnd = 0
    DSend (stList)
'    MSComm1.Output = stSend
End If
End Sub

'数据有返回时的响应
Private Sub MSComm1_OnComm()
    Dim DataRead() As Byte
    Dim bytData As Variant '用来从接收缓冲区读取数据
    
    Dim dispstr As String
    
    
    On Error Resume Next
    For i = 0 To 10000
          ReadStr = ""
    Next i
    With MSComm1
        Select Case .CommEvent
        Case comEvReceive
          
          
          bytData = .Input
        ReDim DataRead(UBound(bytData)) As Byte
        For i = 0 To UBound(bytData)
           DataRead(i) = bytData(i)
           ReadStr = ReadStr & Hex2((DataRead(i)))
        Next i
     
        If Option1.value = True Then
            sttxt = sttxt + ReadStr
            If Len(sttxt) = 260 Then
               Print #2, sttxt
               If Right(sttxt, 26) = "00000000000000000000000000" Then
                   Close #2
                   Lab2.Caption = "采集完毕"
                   Lab2.Refresh
                   File1.Refresh
               End If
               sttxt = ""
               n = n + 1
            End If
        End If
     
        If Option2.value = True Then
            sttxt1 = sttxt1 + ReadStr
            
            If Mid(sttxt1, 1, 2) <> "BD" Then
                sttxt1 = ""
                ReadStr = ""
                MSComm1.OutBufferCount = 0 '清除发送缓冲区
                MSComm1.InBufferCount = 0 '清除接收缓冲区
                MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
'                MSComm1.Output = stSend '发送数据
                DSend (stList)
                Exit Sub
            End If
            
            
'''            If Len(sttxt1) < Val(Hex2Dec(Mid(sttxt1, 3, 2))) * 2 + 4 Then
'''                sttxt1 = ""
'''                ReadStr = ""
''''                MSComm1.OutBufferCount = 0 '清除发送缓冲区
''''                MSComm1.InBufferCount = 0 '清除接收缓冲区
''''                MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
'''                DSend (stList)
''''                For i = 1 To 1000
''''                sttxt1 = ""
''''                Next i
'''                Exit Sub
'''            End If
            
''''            If Mid(sttxt1, 5, 2) > "90" Or Mid(sttxt1, 5, 2) < "8D" Then
''''                sttxt1 = ""
''''                ReadStr = ""
''''                MSComm1.OutBufferCount = 0 '清除发送缓冲区
''''                MSComm1.InBufferCount = 0 '清除接收缓冲区
''''                MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
''''                MSComm1.Output = stSend '发送数据
''''                Exit Sub
''''            End If
''''
''''            If Mid(sttxt1, 3, 2) = "16" And Len(sttxt1) < 48 Then
''''                Exit Sub
''''            End If
            
            If Len(sttxt1) > 48 Then
                sttxt1 = ""
                ReadStr = ""
                MSComm1.OutBufferCount = 0 '清除发送缓冲区
                MSComm1.InBufferCount = 0 '清除接收缓冲区
                MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
                DSend (stList)
'                MSComm1.Output = stSend '发送数据
                Exit Sub
            End If
            
            Select Case Mid(sttxt1, 5, 2)
            Case "8F" '采集记录
                If Mid(sttxt1, 3, 2) = "16" Then '有效记录
                    If Len(sttxt1) = 48 Then
                       Print #3, sttxt1
                       sttxt1 = ""
                       MSComm1.OutBufferCount = 0 '清除发送缓冲区
                       MSComm1.InBufferCount = 0 '清除接收缓冲区
'                       MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
                       stSend(0) = &HBA
                       stSend(1) = &H4
                       stSend(2) = &H8F
                       psRecordID = psRecordID + 1
                       sttxt = hex(CDbl(psRecordID))
                       sttxt = Right("0000" + sttxt, 4)
                       stSend(3) = "&H" + Mid(sttxt, 1, 2)
                       stSend(4) = "&H" + Mid(sttxt, 3, 2)
                       stSend(5) = &H0
                       For i = 0 To 4
                           stSend(5) = stSend(5) Xor stSend(i)
                       Next
                       stList = ""
                       For n = 0 To 5
                            stList = stList + Right("00" + hex(stSend(n)), 2)
                       Next n
                       DSend (stList)
'                       MSComm1.Output = stSend '发送数据
                    Else
''''                       MSComm1.OutBufferCount = 0 '清除发送缓冲区
''''                       MSComm1.InBufferCount = 0 '清除接收缓冲区
''''                       MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
'''''                       MSComm1.Output = stSend '发送数据
''''                       DSend (stList)
                    End If
                End If
            
                If Mid(sttxt1, 3, 2) = "03" Then '采集完毕
                    Close #3
                    sttxt1 = ""
                    Command1.Enabled = True