frmset.frm

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

           If Len(sttxt) = 10 Then
                
                MsgBox "设置密码成功！"
                sttxt = ""
           End If
     End Select
'''''     If Len(sttxt) = 260 Then
''''''        List1.AddItem sttxt
''''''        List1.AddItem n
'''''        Print #2, sttxt
'''''        If Right(sttxt, 26) = "00000000000000000000000000" Then
'''''            Close #2
'''''            Lab2.Caption = "采集完毕"
'''''            Lab2.Refresh
'''''            File1.Refresh
'''''        End If
'''''''        Set rs = GetRecordset(maSys_db, "select *  from databuff where databuff260='" & Trim(sttxt) & "' ")
'''''''        If Not (rs.EOF And rs.BOF) Then
'''''''            'MsgBox "该卡号在数据库中已经存在，请检查！", vbInformation + vbOKOnly, "提示"
'''''''        Else
'''''''            '增加记录
'''''''            pscard.Open "select * from databuff", maSys_db, 3, 3
'''''''            pscard.AddNew
'''''''            pscard.Fields("databuff26") = Trim(sttxt)
'''''''
'''''''            pscard.Update
'''''''            pscard.Close
'''''''
'''''''        End If
'''''        sttxt = ""
'''''        n = n + 1
'''''
'''''     End If
     '/End If
     
'     If DataRead(1) = 22 Then
'         rsLen = 1
'         MSComm1.OutBufferCount = 0 '清除发送缓冲区
'         MSComm1.InBufferCount = 0 '清除接收缓冲区
'         MSComm1.RThreshold = 1 '设置引发OnComm事件的字节长度
'         DataHex(0) = &HBA
'         DataHex(1) = &H4
'         DataHex(2) = &H8F
'
'         rsSend = rsSend + 1
'         sttxt = hex(CDbl(rsSend))
'         sttxt = Right("0000" + sttxt, 4)
'         DataHex(4) = "&H" + Mid(sttxt, 3, 2)
'         DataHex(3) = "&H" + Mid(sttxt, 1, 2)
'         DataHex(5) = &H0
'         For i = 0 To 4
'         DataHex(5) = DataHex(5) Xor DataHex(i)
'         Next
'         Text3 = rsSend
'         MSComm1.Output = DataHex '发送数据
'     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 stimes As String

stimes = Format(Now, "yymmddhhmmss")
stSendTmp(0) = &HBA
stSendTmp(1) = &H5
stSendTmp(2) = &H81
stSendTmp(3) = "&H" + Mid(stimes, 1, 2)
stSendTmp(4) = "&H" + Mid(stimes, 3, 2)
stSendTmp(5) = "&H" + Mid(stimes, 5, 2)
stSendTmp(6) = &H0
For n = 0 To 5
    stSendTmp(6) = stSendTmp(6) Xor stSendTmp(n)
Next n

stSend(0) = stSendTmp(0)
stSend(1) = stSendTmp(1)
stSend(2) = &H82
stSend(3) = "&H" + Mid(stimes, 7, 2)
stSend(4) = "&H" + Mid(stimes, 9, 2)
stSend(5) = "&H" + Mid(stimes, 11, 2)
stSend(6) = &H0
For n = 0 To 5
    stSend(6) = stSend(6) Xor stSend(n)
Next n

DoType = 81
stList = ""
For n = 0 To 6
    stList = stList + Right("00" + hex(stSendTmp(n)), 2)
Next n
DSend (stList)
''''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 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
''''        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") '持卡人
''''
''''                    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.Update
''''                        rsdb.Close
''''                    End If
''''                Else
''''                    '找不到该卡号记录信息，记录不做处理
''''                End If
''''            End If
''''        Next n
''''    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() '下载密码

Dim stimes As String


stSendTmp(0) = &HBA 'KEYA
stSendTmp(1) = &HA
stSendTmp(2) = &H88
For n = 3 To 10
    stSendTmp(n) = &H11
Next n
stSendTmp(11) = &H0

For n = 0 To 10
    stSendTmp(11) = stSendTmp(11) Xor stSendTmp(n)
Next n

stSend(0) = &HBA 'KEYB
stSend(1) = &HA
stSend(2) = &H8A
For n = 3 To 10
    stSend(n) = &H11
Next n
stSend(11) = &H0

For n = 0 To 10
    stSend(11) = stSend(11) Xor stSend(n)
Next n

stList = ""
For n = 0 To 11
    stList = stList + Right("00" + hex(stSendTmp(n)), 2)
Next n
DSend (stList)

End Sub

Private Sub Form_Load()
'    MSComm1.CommPort = Right(Combo1.Text, 1)
'    MSComm1.Settings = Combo2.Text & "," & Combo3.Text & "," & Combo4.Text & "," & Combo5.Text
'    MSComm1.PortOpen = True '打开通信口


 Me.Top = (Screen.Height - Me.Height) / 2
 Me.Left = (Screen.Width - Me.Width) / 2
    
    
 Combo1.Clear
 Combo1.AddItem "COM1"
 Combo1.AddItem "COM2"

 If comPort = 1 Then
     Combo1.Text = "COM1"
 Else
     Combo1.Text = "COM2"
 End If
 
 Combo2.Clear
 Combo2.AddItem "9600"
 Combo2.AddItem "38400"
 Combo2.AddItem "115200"
 
 If Mid(comSet, 1, 4) = "9600" Then
     Combo2.Text = "9600"
 ElseIf Mid(comSet, 1, 4) = "1152" Then
     Combo2.Text = "115200"
 Else
     Combo2.Text = "38400"
 End If
 
 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

'On Error GoTo Err1
 If MSComm1.PortOpen = False Then
    MSComm1.CommPort = comPort
    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