frm_hyicaddmoney.frm

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

        MsgBox "减值不成功！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
    End If
End If
err:
cmdicf.Enabled = False
cmdicd.Enabled = False
cmdict.Enabled = False
cmdictd.Enabled = False
Call ReaderClose

End Sub

Private Sub cmdicf_Click() '充值

If Val(txtMoney) <= 0 Then
     txtMoney.Text = ""
     MsgBox "充值金额输入错误，请重新输入！", vbInformation + vbOKOnly, "中芯德立提示信息"
     Exit Sub
End If

If ReaderOpen = False Then MsgBox "未检测到IC卡读写器，请检查！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub

'Function R_CardFull(sp_AddMoney As Currency, sp_BeforeMoney As Currency, sp_AfterMoney As Currency, sp_String As String) As Boolean '充值
sAddmoney = Val(txtMoney)
If R_CardFull(sAddmoney, sBalance, sAftermoney, sErr) = True Then
    maSys_db.Execute "insert into 充值积分明细表(IC卡号,卡上余额,卡上积分,充值金额,赠送积分,操作员,操作时间,操作类型,员工编号,IC卡类)" _
                        & "values('" & Format(sCardid, "00000000") & "'," & sAftermoney & ",0," _
                        & sAddmoney & ",0,'" & strUserName & "'," & "'" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "'," _
                        & "'充值','" & Trim(txtEmpID) & "','" & Format(sCardTYpe, "00") & "')"
    Call listrecord
    txtAfterMoney = sAftermoney
    Call ReaderSound(2)
    MsgBox "充值成功！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
Else
    MsgBox "充值不成功！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
End If

err:
cmdicf.Enabled = False
cmdicd.Enabled = False
cmdict.Enabled = False
cmdictd.Enabled = False
Call ReaderClose

End Sub

Private Sub cmdicm_Click() '验卡
txtAfterMoney = ""
sClsLabel
If ReaderOpen = False Then MsgBox "未检测到IC卡读写器，请检查！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
If sKey = "" Then
    MsgBox "请先将密码卡放在感应区！", vbInformation + vbOKOnly, "中芯德立提示信息"
    If R_CardKey(sKey, sErr) = False Then MsgBox "密码装载失败！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
    sKey = Mid(sErr, 1, 8) & Mid(sErr, 17, 8)
    MsgBox "OK，请保管好密码卡，将用户卡放在读写器感应区！", vbInformation + vbOKOnly, "中芯德立提示信息"
End If

If sKey = "" Then
    MsgBox "请将密码卡放在感应区！", vbInformation + vbOKOnly, "中芯德立提示信息"
    sKey = "1111111111111111"
    MsgBox "密码装载成功，请保管好密码卡！", vbInformation + vbOKOnly, "中芯德立提示信息"
    Exit Sub
End If

If R_Cardcheck(sKey, sCardid, sCardTYpe, sBalance, sDate, sMonth, sErr) = True Then
    
    If Format(sCardTYpe, "00") > "32" Then
        MsgBox "该卡是管理卡！", vbInformation + vbOKOnly, "中芯德立提示信息"
        cmdicf.Enabled = False
        cmdicd.Enabled = False
        GoTo err
    End If
    
    Set rs = GetRecordset(maSys_db, "select * from 员工信息临时表 where IC卡号='" & Format(sCardid, "00000000") & "'")
    If Not rs.EOF Then
        'sTest = Format(sCardid, "00000000") & Format(sCardTYpe, "00") & Format(sBalance, "0000.00") & sDate & rs.Fields("员工姓名")
        Label1.Caption = Label1.Caption & Format(sCardid, "00000000")
        Label2.Caption = Label2.Caption & rs.Fields("员工编号")
        Label3.Caption = Label3.Caption & rs.Fields("员工姓名")
        Label4.Caption = Label4.Caption & Format(sCardTYpe, "00")
        Label5.Caption = Label5.Caption & Trim(str(Val(sBalance))) & "元"
        txtEmpID = rs.Fields("员工姓名")
        List1.Clear
        If sMonth <> "" Then '月票信息
            Dim n As Integer
            Dim slist As String
            n = 1
            
            For i = 0 To 11
                slist = Mid(sMonth, n, 9) '200711255
                If Left(slist, 6) >= Format(Now, "yyyymm") And Val(Right(slist, 3)) > 0 Then
                     List1.AddItem Mid(slist, 1, 4) & "年" & Mid(slist, 5, 2) & "月" & str(Val(Right(slist, 3))) & "次"
                     List1.ListIndex = List1.ListCount - 1
                End If
                n = n + 9
            Next i
            
        End If
        cmdicf.Enabled = True
        cmdicd.Enabled = True
        cmdict.Enabled = True
        cmdictd.Enabled = True
        ReaderSound (2)
        
        txtMoney = ""
        txtMoney.SetFocus
    Else
        MsgBox "该卡在数据库中不存在，请重试！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
    End If
    
Else
     If sErr = "ERR 1010" Then
        cmdicf.Enabled = False
        cmdicd.Enabled = False
        ReaderSound (2)
        MsgBox "该卡是新卡！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
     ElseIf sErr = "ERR 1014" Then
        MsgBox "该卡是黑名单卡，请收回！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
     Else
        MsgBox "验卡错误，请重试！", vbInformation + vbOKOnly, "中芯德立提示信息": GoTo err
     End If
End If

err:
Call ReaderClose

End Sub
Private Sub sClsLabel()
Label1.Caption = "IC 卡 号："
Label2.Caption = "人员编号："
Label3.Caption = "人员名称："
Label4.Caption = "IC卡类型："
Label5.Caption = "卡上余额："
End Sub

Private Sub cmdicq_Click()
Unload Me
End Sub

Private Sub cmdicMonth() '充次
Dim sTimes As String
Dim sTimesDate As String
Dim sTimesCurY As String '卡上当前年份
Dim sTimesCurM As String '卡上当前月份
Dim sTimesCur As String

Dim sTimesB(16) As Byte
Dim sMonthB(16) As Byte
Dim sMonthTmp(16) As Byte
Dim sIndex As Integer
Dim i As Integer
Dim n As Integer
Dim sMonthTimes As Integer

For i = 0 To 15
     sTimesB(i) = &H0
     sMonthTmp(i) = &H0
Next
If DTPicker1.Value = "" Then MsgBox "日期选择有错误，请重输！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
sTimesDate = Format(DTPicker1.Value, "yyyymm")
If sMonthTF = "11" Then
    If Val(txtTimes.Text) > 255 Or Val(txtTimes.Text) <= 0 Then MsgBox "充次次数输入错误，请重输！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
    If sMonth = "" Then '第一次充次
        If sTimesDate >= Format(Now, "yyyymm") Then '如果充入月份大于或等于当前月份
            sTimes = Right("0000" + hex(Val(Mid(Now, 1, 4))), 4)
            sTimesB(0) = "&h" + Right(sTimes, 2)
            sTimesB(1) = "&h" + Left(sTimes, 2)
            sTimesB(2) = "&h" + hex(Val(Format(Now, "mm")))
            '充次并非一定要是当前月开始
            'If Val(Mid(sTimesDate, 1, 4)) - Val(Format(Now, "yyyy")) > 1 Then MsgBox "充次年份选择错误！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
            sIndex = (Val(Mid(sTimesDate, 1, 4)) - Val(Format(Now, "yyyy"))) * 12 + Val(Mid(sTimesDate, 5, 2)) - Val(Format(Now, "mm")) + 3
            If sIndex >= 15 Then MsgBox "超出充次边界，不可充次！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
            sTimesB(sIndex) = "&h" + hex(Val(txtTimes.Text))
            sTimes = ""
            For i = 0 To 14
                 sTimesB(15) = sTimesB(15) Xor sTimesB(i)
                 sTimes = sTimes & Right("00" + hex(sTimesB(i)), 2)
            Next i
            sTimes = sTimes & Right("00" + hex(sTimesB(15)), 2)
        Else
            MsgBox "该月已经过期，不可充次！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
        End If
    End If
End If
If sMonth <> "" Then '非第一次充次
    sTimesCurY = Mid(sMonth, 1, 4)
    sTimesCurM = Mid(sMonth, 5, 2)
    sTimesCur = Mid(sMonth, 1, 6)
    '先确定当前年份及月份，将过期月份前移
    n = 1
    For i = 3 To 14 '2007110002007120002
         sMonthB(i) = Val(Mid(Mid(sMonth, n, 9), 7, 3))
         sMonthTmp(i) = Val(Mid(Mid(sMonth, n, 9), 7, 3))
         n = n + 9
    Next i
    
    For i = 0 To 11 '过期月前移
         If sTimesCur < Format(Now, "yyyymm") Then
            For n = 3 To 13
                  sMonthTmp(n) = sMonthTmp(n + 1)
            Next n
            sMonthTmp(14) = &H0
            sTimesCurM = sTimesCurM + 1
            If sTimesCurM > 12 Then
                sTimesCurY = sTimesCurY + 1
                sTimesCurM = 1
            End If
            sTimesCur = Format(sTimesCurY, "0000") & Format(sTimesCurM, "00")
         End If
    Next i
       
    If Mid(sTimesDate, 1, 6) >= sTimesCur Then '充次月份必须大于卡当前月
         'If Val(Mid(sTimesDate, 1, 4)) - Val(Mid(sTimesCur, 1, 4)) > 1 Then MsgBox "充次年份选择错误！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
         sIndex = (Val(Mid(sTimesDate, 1, 4)) - Val(Mid(sTimesCur, 1, 4))) * 12 + Val(Mid(sTimesDate, 5, 2)) - Val(Mid(sTimesCur, 5, 2)) + 3
         If sIndex >= 15 Then MsgBox "超出充次边界，不可充次！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
         
         If sMonthTF = "11" Then
            If sMonthTmp(sIndex) = 0 Then
                sMonthTmp(sIndex) = Val(txtTimes.Text)
            Else
                MsgBox "该月已经充次，不能再充！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
            End If
         Else
            If sMonthTmp(sIndex) = 0 Then
                MsgBox "该月次数为0，不可执行该操作！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
            Else
                sMonthTimes = sMonthTmp(sIndex)
                sMonthTmp(sIndex) = &H0
            End If
         End If
     Else
         MsgBox "该月已经过期，不可操作！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
     End If
     
     sTimes = Right("0000" + hex(Val(Mid(sTimesCur, 1, 4))), 4)
     sMonthTmp(0) = "&h" + Right(sTimes, 2)
     sMonthTmp(1) = "&h" + Left(sTimes, 2)
     sMonthTmp(2) = "&h" + hex(Val(Mid(sTimesCur, 5, 2)))
     sTimes = ""
     
     For i = 0 To 14
         sMonthTmp(15) = sMonthTmp(15) Xor sMonthTmp(i)
         sTimes = sTimes & Right("00" + hex(sMonthTmp(i)), 2)
     Next i
     sTimes = sTimes & Right("00" + hex(sMonthTmp(15)), 2)
     
'     sMonth = ""
'     For n = 0 To 15
'          sMonth = sMonth & Right("00" + hex(sMonthTmp(n)), 2)
'     Next n
End If
If ReaderOpen = False Then MsgBox "未检测到IC卡读写器，请检查！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
If R_CardMonth(sTimes, sErr) = True Then
    
    ReaderSound (2)
    If sMonthTF = "11" Then
        maSys_db.Execute "insert into 充值积分明细表(IC卡号,卡上余额,卡上积分,充值金额,赠送积分,操作员,操作时间,操作类型,员工编号,IC卡类,月份)" _
                        & "values('" & Format(sCardid, "00000000") & "'," & sBalance & ",0," _
                        & "0," & Val(txtTimes.Text) & ",'" & strUserName & "'," & "'" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "'," _
                        & "'充次','" & Trim(txtEmpID) & "','" & Format(sCardTYpe, "00") & "','" & sTimesDate & "')"
        Call listrecord
        MsgBox "充次成功！", vbInformation + vbOKOnly, "中芯德立提示信息"
    Else
        maSys_db.Execute "insert into 充值积分明细表(IC卡号,卡上余额,卡上积分,充值金额,赠送积分,操作员,操作时间,操作类型,员工编号,IC卡类,月份)" _
                        & "values('" & Format(sCardid, "00000000") & "'," & sBalance & ",0," _
                        & "0," & sMonthTimes & ",'" & strUserName & "'," & "'" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "'," _
                        & "'减次','" & Trim(txtEmpID) & "','" & Format(sCardTYpe, "00") & "','" & sTimesDate & "')"
        Call listrecord
        MsgBox "充正成功！", vbInformation + vbOKOnly, "中芯德立提示信息"
    End If
    
Else
    If sMonthTF = "11" Then
        MsgBox "充次不成功！", vbInformation + vbOKOnly, "中芯德立提示信息"
    Else
        MsgBox "次娄充正不成功！", vbInformation + vbOKOnly, "中芯德立提示信息"
    End If
End If

Call ReaderClose
End Sub

Private Sub cmdict_Click() '充次
sMonthTF = "11"
Call cmdicMonth
cmdicf.Enabled = False
cmdicd.Enabled = False
cmdict.Enabled = False
cmdictd.Enabled = False
End Sub

Private Sub cmdictd_Click() '次数充正
sMonthTF = "00"
If sMonth = "" Then MsgBox "月票区没有有效次数，不能执行充正操作！", vbInformation + vbOKOnly, "中芯德立提示信息": Exit Sub
Call cmdicMonth
cmdicf.Enabled = False
cmdicd.Enabled = False
cmdict.Enabled = False
cmdictd.Enabled = False
End Sub

Private Sub Form_Load()
Me.Top = (Screen.Height - Me.Height) / 2
Me.Left = (Screen.Width - Me.Width) / 2
cmdicf.Enabled = False
cmdicd.Enabled = False
cmdict.Enabled = False
cmdictd.Enabled = False
sWhere = "select * from 充值积分明细表 order by 操作时间 desc "
Call listrecord
End Sub

Private Sub listrecord()
Dim L As ListItem
Dim i As Integer
Dim rs As New ADODB.Recordset
Set rs = GetRecordset(maSys_db, sWhere)
ListViewF.ColumnHeaders.Clear
ListViewF.ListItems.Clear
ListViewF.View = lvwReport
ListViewF.ColumnHeaders.Add , , "ID", 800
ListViewF.ColumnHeaders.Add , , "IC卡号", 1400
ListViewF.ColumnHeaders.Add , , "卡上余额", 1100
ListViewF.ColumnHeaders.Add , , "充值金额", 1100
ListViewF.ColumnHeaders.Add , , "操作类型", 1100
ListViewF.ColumnHeaders.Add , , "次数", 1100
ListViewF.ColumnHeaders.Add , , "操作员", 1100
ListViewF.ColumnHeaders.Add , , "操作时间", 2500
ListViewF.ColumnHeaders.Add , , "月份", 1500
i = 1
If rs.EOF Then Exit Sub
rs.MoveFirst
Do While Not rs.EOF
    Set L = ListViewF.ListItems.Add(, , i)
        L.SubItems(1) = CStr(rs!IC卡号)
        L.SubItems(2) = CStr(rs!卡上余额)
        L.SubItems(3) = CStr(rs!充值金额)
        L.SubItems(4) = CStr(rs!操作类型)
        L.SubItems(5) = CStr(rs!赠送积分)
        L.SubItems(6) = CStr(rs!操作员)
        L.SubItems(7) = CStr(rs!操作时间)
        L.SubItems(8) = Trim("  " & rs!月份)
        i = i + 1
        rs.MoveNext
Loop
End Sub

Private Sub txtMoney_KeyPress(KeyAscii As Integer)

If KeyAscii > 57 Or KeyAscii < 48 And KeyAscii <> 8 Then
        KeyAscii = 0
End If
End Sub

'Private Sub txtTimes_KeyPress(KeyAscii As Integer)
'If KeyAscii = 13 Then Call txtTimes_LostFocus
'If KeyAscii > 57 Or KeyAscii < 48 And KeyAscii <> 8 Then
'        KeyAscii = 0
'End If
'End Sub
'
'Private Sub txtTimes_LostFocus()
'If Val(txtTimes) <= 0 Then
'     txtTimes.Text = ""
'     MsgBox "积分输入错误，请重新输入！", vbInformation + vbOKOnly, "中芯德立提示信息"
'End If
'End Sub