form1.frm

一款基于标准IC卡考勤数据读写操作示例的开发源程序。主要给需要开发IC卡和考勤系统的网友学习参考用

  cardTimes As Long
  cardGroup As Long
End Type


'Public Function SHL(ByVal OPR As Long，ByVal n As Long，ByVal cf As Boolean）As Long
'Dim BD As Byte
'Dim I As Integer
'BD = OPR
'For I = 1 To n - 1
'BD = (BD And &H7F) * 2    '屏蔽最高位（防止溢出），并且整体左移一位
'Next I
'cf = BD And &H80             '返回最后一次左移前的进位数（最高位）
'SHL = (BD And &H7F) * 2     '最后一次左移
'End Function

'Public Function SHR（OPR As Byte，n As Integer，cf As Boolean）As Byte
'Dim BD As Byte
'Dim I As Byte
'BD = OPR
'For I = 1 To n - 1
'BD = BD \ 2                 '整体右移
'Next I
'cf = BD And 1                '返回最后一次右移前的进位数（最底位）
'SHR = BD \ 2                '最后一次右移
'End Function



Public Function D_To_B(ByVal Dec As Long) As String
    Do
        D_To_B = Dec Mod 2 & D_To_B
        Dec = Dec \ 2
    Loop While Dec
End Function

Public Function B_To_D(ByVal Bin As String) As Integer
    Dim I As Long
    For I = 1 To Len(Bin)
        B_To_D = B_To_D * 2 + Val(Mid(Bin, I, 1))
    Next I
End Function

Public Function H_To_B(ByVal Hex As String) As String
    Dim I As Long
    Dim B As String
    
    Hex = UCase(Hex)
    For I = 1 To Len(Hex)
        Select Case Mid(Hex, I, 1)
            Case "0": B = B & "0000"
            Case "1": B = B & "0001"
            Case "2": B = B & "0010"
            Case "3": B = B & "0011"
            Case "4": B = B & "0100"
            Case "5": B = B & "0101"
            Case "6": B = B & "0110"
            Case "7": B = B & "0111"
            Case "8": B = B & "1000"
            Case "9": B = B & "1001"
            Case "A": B = B & "1010"
            Case "B": B = B & "1011"
            Case "C": B = B & "1100"
            Case "D": B = B & "1101"
            Case "E": B = B & "1110"
            Case "F": B = B & "1111"
        End Select
    Next I
    While Left(B, 1) = "0"
        B = Right(B, Len(B) - 1)
    Wend
    H_To_B = B
End Function

Public Function B_To_H(ByVal Bin As String) As String
    Dim I As Long
    Dim H As String
    If Len(Bin) Mod 4 <> 0 Then
        Bin = String(4 - Len(Bin) Mod 4, "0") & Bin
    End If
    
    For I = 1 To Len(Bin) Step 4
        Select Case Mid(Bin, I, 4)
            Case "0000": H = H & "0"
            Case "0001": H = H & "1"
            Case "0010": H = H & "2"
            Case "0011": H = H & "3"
            Case "0100": H = H & "4"
            Case "0101": H = H & "5"
            Case "0110": H = H & "6"
            Case "0111": H = H & "7"
            Case "1000": H = H & "8"
            Case "1001": H = H & "9"
            Case "1010": H = H & "A"
            Case "1011": H = H & "B"
            Case "1100": H = H & "C"
            Case "1101": H = H & "D"
            Case "1110": H = H & "E"
            Case "1111": H = H & "F"
        End Select
    Next I
    B_To_H = H
End Function





Private Function CheckHandle() As Boolean
  If (hPort <> 0) And (hPort <> -1) Then
    CheckHandle = True
  Else
    CheckHandle = False
  End If
End Function

Private Function OpenPort(ByVal Port As Long, ByVal BaudRate As Long, ByVal clock_id As Integer) As Boolean
  Dim Result As Boolean
  Dim Model As Integer
  Dim Fireware As Double
  Dim cls As Integer
  If CheckHandle Then
    Result = True
  Else
    'hPort = ConnectClock(Port, BaudRate, clock_id)
    hPort = OpenCommPort(Port, BaudRate)
    SetCmdVerify (True)
    If CallClock(hPort, clock_id) Then
      If GetClockModel(hPort, Model, Fireware, cls) Then
        Result = CheckHandle
        OpenPort = Result
      End If
    End If
  End If
End Function
  
Private Function ClosePort() As Boolean
  Dim Result
  Result = False
  If CheckHandle Then
      DisConnectClock (hPort)
      Result = True
      hPort = 0
  End If
  ClosePort = Result
  ' AddLog "[" + Format(clock_id, "00") + "]号机端口已关闭"
End Function

Public Sub AddLog(Str As String)
  Text5.Text = Format(Now, "yyyy-mm-dd hh:mm:ss    ") + Str
End Sub

Private Sub RefreshClock()
  Port = CInt(Text2.Text)
  BaudRate = CLng(bRate.Text)
  clock_id = CLng(Text1.Text)
  ipPort = CInt(ipPort.Text)
  ipAddr = ipAddr.Text
  End Sub

Public Function ReadICCardProc(hPort As Long, ByRef card_id As String, ByRef card_name As String, ByRef card_money As Long, ByRef card_times As Long, ByRef card_style As Long) As Boolean
  Dim st As Long
  Dim c As Long
  ReadICCardProc = False
  c = 0
  Do While True = True
    If ReadICCard(hPort, card_id, card_name, card_money, card_times, card_style) Then
      ReadICCardProc = True
      Exit Do
    End If
    c = c + 1
    If c > 3 Then Exit Function
  Loop
End Function

Public Function WriteICCardProc(hPort As Long, ByVal card_id As String, ByVal card_name As String, ByVal card_money As Long, ByVal card_times As Long, ByVal card_style As Long) As Boolean
  Dim st As Long
  WriteICCardProc = False
  Dim rcard_id As String * 50
  Dim rcard_name As String * 50
  Dim rcard_money As Long
  Dim rcard_times As Long
  Dim rcard_style As Long
  Dim c As Long
  c = 0
  Do While True = True
    If ReadICCard(hPort, rcard_id, rcard_name, rcard_money, rcard_times, rcard_style) Then
      If WriteICCard(hPort, card_id, card_name, card_money, card_times, card_style) Then
        WriteICCardProc = True
        Exit Do
      End If
    End If
    c = c + 1
    If c > 50 Then Exit Do
  Loop
End Function

Private Sub btnClockPW_Click()
Dim Right As Boolean
FrmClockPW.Show vbModal, Me
RefreshClock
If FrmClockPW.OkFlag Then
  If OpenPort(Port, BaudRate, clock_id) Then
    Right = SetSecurityCode(hPort, Trim(FrmClockPW.txOldPW.Text), Trim(FrmClockPW.txNewPW.Text))
    If Right Then
      MsgBox ("更改设备密码成功")
    Else
      MsgBox ("更改密码失败")
    End If
      ClosePort
    Else
      ClosePort
      MsgBox ("不能连接设备")
  End If
End If
End Sub

Private Sub btnReadCard_Click()
  Dim card_buf As String * 50
  Dim name_buf As String * 50
  Dim card_money As Long
  Dim card_times As Long
  Dim card_style As Long
  RefreshClock
   If OpenPort(Port, BaudRate, clock_id) Then
     If ReadICCardProc(hPort, card_buf, name_buf, card_money, card_times, card_style) Then
       edCardId.Text = card_buf
       edCardName.Text = name_buf
       edCardMoney.Text = card_money / 10
       edCardTimes.Text = card_times
       Select Case card_style
         Case CARDSTYLE_OLDCARD
           cbCardStyle.ListIndex = 0
         Case CARDSTYLE_NEWCARD
           cbCardStyle.ListIndex = 1
         Case CARDSTYLE_690CARD
           cbCardStyle.ListIndex = 2
       End Select
       MsgBox ("读卡成功")
     Else
       MsgBox ("读卡错误")
     End If
     ClosePort
  Else
     MsgBox ("不能联接设备")
  End If
End Sub

Private Sub btnWriteCard_Click()
  Dim card_buf As String * 50
  Dim name_buf As String * 50
  Dim card_money As Long
  Dim card_times As Long
  Dim card_style As Long
  RefreshClock
    If OpenPort(Port, BaudRate, clock_id) Then
      Select Case cbCardStyle.ListIndex
        Case 0
          card_style = CARDSTYLE_OLDCARD
        Case 1
          card_style = CARDSTYLE_NEWCARD
        Case 2
          card_style = CARDSTYLE_690CARD
      End Select
      card_buf = edCardId.Text
      name_buf = edCardName.Text
      card_money = edCardMoney.Text * 10
      card_times = edCardTimes.Text
      If WriteICCardProc(hPort, card_buf, name_buf, card_money, card_times, card_style) Then
         'WriteICCardPassWord hPort, edCardPW.Text
        MsgBox ("写卡成功")
      Else
        MsgBox ("写卡错误")
      End If
      ClosePort
   Else
      MsgBox ("不能联接设备")
   End If
End Sub

Private Sub cmd_readshowmsg_Click()
  Dim CardMsg As String
  Dim Str As String
  Dim S As Integer
  Dim I As Integer
  Dim Bt As Byte
  
  
  RefreshClock
  If OpenPort(Port, BaudRate, clock_id) Then
    'Text5.Text = "[" + CStr(port) + "  号端口 " + CStr(clock_id) + "  号机 成功打开！"
    If ReadCardMessageString(hPort, CardMsg, CInt(TextBlock.Text)) Then
       'Str = ""
       'For I = 1 To 25
       '  S = Asc(Mid(CardMsg, I, 1))
       '  Str = Str + B_To_H(D_To_B(S))
       'Next I
       Text5.Text = CardMsg ' Str 'B_To_H(D_To_B(Asc(S)))
    Else
       Text5.Text = "不能读出设备的常态显示内容"
    End If
    ClosePort
  Else
    Text5.Text = "不能联接设备"
  End If
End Sub

Private Sub cmd_writemsg_Click()
  Dim CardMsg As String
  Dim Str As String
  Dim S As Integer
  Dim I As Integer
  Dim Bt As Byte
  CardMsg = Text5.Text
    
  RefreshClock
  If OpenPort(Port, BaudRate, clock_id) Then
    'Text5.Text = "[" + CStr(port) + "  号端口 " + CStr(clock_id) + "  号机 成功打开！"
    If WriteCardMessageString(hPort, CardMsg, CInt(TextBlock.Text)) Then
       'Str = ""
       'For I = 1 To 25
       '  S = Asc(Mid(CardMsg, I, 1))
       '  Str = Str + B_To_H(D_To_B(S))
       'Next I
       Text5.Text = "写块信息成功" ' Str 'B_To_H(D_To_B(Asc(S)))
    Else
       Text5.Text = "写块信息失败"
    End If
    ClosePort
  Else
    Text5.Text = "不能联接设备"
  End If
End Sub

Private Sub Command1_Click()
 Dim flag As Boolean
  Dim K As Long
  Dim nLine As Long
  Dim DataBuff As String * 2000
  Dim strLine As String
  Dim Count As Long
  
  Count = 0
  flag = True
  RefreshClock
  If OpenPort(Port, BaudRate, clock_id) Then
      'Text5.Text = "[" + CStr(port) + "  号端口" + CStr(clock_id) + "  号机 成功打开！"
      Do While flag = True
                nLine = BatchReadRecord(hPort, DataBuff, 1100)
                'If nLine = 0 Or nLine = -1 Then flag = Flase
                If nLine > 0 Then
                Open (FileName) For Append As #1
                'List1.AddItem DataBuff
                For K = 0 To nLine - 1 '原66，现修改后为114 格式：机号+卡号+时间+标志
                    'strLine = CStr(clock_id) + vbTab + Format(Mid(DataBuff, K * 114 + 1, 10), "0000000000") + vbTab + Mid(DataBuff, K * 114 + 21, 14) + vbTab + Str(Asc(Mid(DataBuff, K * 114 + 55, 1)) And 63)+ vbTab + Str(Asc(Mid(DataBuff, K * 114 + 55, 1)) shr 6)
                     List1.AddItem strLine
                     Print #1, strLine
                     Count = Count + 1
                Next K
              Close #1
              Else
                flag = False
              End If
              
         Loop
    If Count > 0 Then
        Text5.Text = "下载记录总数" & Count
     Else
        Text5.Text = CStr(clock_id) & " 号机内没有数据"
     End If
    ClosePort
   Else
     Text5.Text = CStr(clock_id) + "号机联机失败"
   End If
End Sub

Private Sub Command10_Click()
  RefreshClock
  If OpenPort(Port, BaudRate, clock_id) Then
    'AddLog "[" + CStr(port) + "  号端口 " + CStr(clock_id) + "  号机 成功打开！"
    If SetClockID(hPort, CInt(Text4.Text)) Then
       Text5.Text = "机号修改成功"
    Else
       Text5.Text = "机号修改失败"
    End If
    ClosePort
  Else
    Text5.Text = "不能联接设备"
  End If
End Sub

Private Sub Command11_Click()
  RefreshClock
  If OpenPort(Port, BaudRate, clock_id) Then
    'AddLog "[" + CStr(port) + "  号端口 " + CStr(clock_id) + "  号机 成功打开！"
    If ClearAllReadCard(hPort) Then
       Text5.Text = "[" + CStr(clock_id) + "]机所有记录已被删除！"
    Else
       Text5.Text = "[" + CStr(clock_id) + "]机删除记录失败。"
    End If
    ClosePort
  Else
    MsgBox ("不能联接设备")
  End If
End Sub

Private Sub Command12_Click()
  RefreshClock
  If OpenPort(Port, BaudRate, clock_id) Then
    'AddLog "[" + CStr(port) + "  号端口 " + CStr(clock_id) + "  号机 成功打开！"
    FrmList.txCard.Text = "下载黑名单"
    FrmList.Show vbModal, Me
    If FrmList.OkFlag Then
      If SetBlackCard(hPort, FrmList.txCard.Text) Then
        Text5.Text = "下载黑名单成功"
      Else
        Text5.Text = "下载黑名单失败"
      End If
    End If
    ClosePort
  Else
    Text5.Text = "不能联接设备"
 End If
End Sub

Private Sub Command13_Click()
  RefreshClock
  If OpenPort(Port, BaudRate, clock_id) Then
    'AddLog "[" + CStr(port) + "  号端口 " + CStr(clock_id) + "  号机 成功打开！"
    FrmList.Caption = "删除白名单"
    FrmList.Show vbModal, Me
    If FrmList.OkFlag Then
    
      If DeleteAllowedCard(hPort, FrmList.txCard.Text) Then
        Text5.Text = "删除白名单成功"
      Else
        Text5.Text = "删除白名单失败"
      End If
    End If
    ClosePort
  Else
    Text5.Text = "不能联接设备"
  End If