contactlessdemovb.frm

omnikey sample app with source

      Caption         =   "Card Name"
      Height          =   255
      Left            =   11400
      TabIndex        =   10
      Top             =   2640
      Width           =   975
   End
   Begin VB.Label Label2 
      Caption         =   "UID"
      Height          =   375
      Left            =   8160
      TabIndex        =   9
      Top             =   2640
      Width           =   495
   End
   Begin VB.Label Label1 
      Caption         =   "ATR"
      Height          =   255
      Left            =   3000
      TabIndex        =   8
      Top             =   2640
      Width           =   735
   End
End
Attribute VB_Name = "ContactLessDemoVB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim hContext As Long
Dim hCard As Long
Dim isContext As Boolean
Dim SelectedReader As String
Dim rc As Long
Dim ATR(64) As Byte
Dim ATRLen As Long
Dim MifKeyNrToReaderStr As String
Dim MifKeyToReader As String
Dim fCardConnected As Boolean
Dim fLookForCard As Boolean

Private Sub Authenticate_Click()
Dim BlockNr As Long
Dim MifareKey(6) As Byte
Dim KeyLen As Long
Dim AccessOption As Byte
Dim Mode As Byte
Dim MifKeyNr As Byte

MifKeyNr = 0

If fCardConnected = False Then
OutPutList.AddItem " At first Card has to be connected"
StatusText.Text = " ERROR"
GoTo EXITSUB
End If

BlockNr = HexStrToInt(BlockNrText.Text)
NumofDataLen = 16

If OptionKeyNr.value = True Then
AccessOption = 1
MifKeyNr = HexStrToInt(AuthenKeyNrText.Text)
End If
If OptionKey.value = True Then
AccessOption = 0
KeyLen = StrToArray(MifareKey, 6, MifAuthentKeyText.Text)
End If

If OptionKey.value = False Then
If OptionKeyNr.value = False Then
OutPutList.AddItem " One Access Option must be selected"
StatusText.Text = " ERROR"
GoTo EXITSUB
End If
End If

If ModeOptionA.value = True Then
Mode = 96
End If
If ModeOptionB.value = True Then
Mode = 97
End If

If ModeOptionA.value = False Then
If ModeOptionB.value = False Then
OutPutList.AddItem " One Authenticate Mode must be selected"
StatusText.Text = " ERROR"
GoTo EXITSUB
End If
End If

rc = SCardCLMifareStdAuthent(hCard, BlockNr, Mode, AccessOption, MifKeyNr, MifareKey(LBound(MifareKey)), KeyLen)

If rc = 0 Then
OutPutList.AddItem " Authentication has been written successfully"
StatusText.Text = " SUCCESS"

End If
If rc <> 0 Then
OutPutList.AddItem " Error in Authentication "
OutPutList.AddItem HandleError(rc)
StatusText.Text = " ERROR"
End If

EXITSUB:
OutPutList.ListIndex = OutPutList.ListCount - 1

End Sub

Private Sub ConnectCard_Click()
Dim i As Integer
Dim curReader As String

Dim myByte As Byte
Dim dwShareMode As Long
Dim dwPreferredProtocols As Long
Dim dwActiveProtocol As Long
Dim UID(12) As Byte
Dim UIDLen As Long

ATRText = ""
UIDText = ""
CardNameText = ""

' get selected Readername from ReaderList
If ReaderList.Text = "" Then
    OutPutList.AddItem "No Reader Selected"
    Exit Sub
Else
    curReader = ReaderList.Text
End If

' Set Mode (see Scard.bas "Modes")
dwShareMode = SCARD_SHARE_SHARED
' Set preferred Protocol (see Scard.bas "Protocols")
dwPreferredProtocols = SCARD_PROTOCOL_T0

' Connect
rc = SCardConnect(hContext, curReader, dwShareMode, dwPreferredProtocols, hCard, dwActiveProtocol)
If rc = 0 Then
OutPutList.AddItem " Card has been connected Succesfully"
StatusText.Text = " SUCCESS"
fCardConnected = True
ATRLen = 64
rc = SCardGetAttrib(hCard, SCARD_ATTR_ATR_STRING, ATR(LBound(ATR)), ATRLen)
If rc = 0 Then
ATRText = ATRText + HexDump(ATR, ATRLen)
UIDLen = 12
rc = SCardCLGetUID(hCard, UID(LBound(UID)), 12, UIDLen)
If rc = 0 Then
UIDText = UIDText + HexDump(UID, UIDLen)
CardNameText = GetCardName()
End If
If rc <> 0 Then
OutPutList.AddItem " Error in SCardCLGetUID"
OutPutList.AddItem HandleError(rc)
StatusText.Text = " ERROR"

End If
End If
If rc <> 0 Then
OutPutList.AddItem "Error in SCardGetAttrib"
OutPutList.AddItem HandleError(rc)
StatusText.Text = " ERROR"

End If
End If
If rc <> 0 Then
OutPutList.AddItem "Error in SCardConnect"
OutPutList.AddItem HandleError(rc)
fCardConnected = False
StatusText.Text = " ERROR"

End If
OutPutList.ListIndex = OutPutList.ListCount - 1
End Sub

Private Sub Decrement_Click()
Dim ucData(4) As Byte
Dim DataLen As Long
Dim BlockNr As Long

If fCardConnected = False Then
OutPutList.AddItem "Card is not Connected"
StatusText.Text = " ERROR"
GoTo EXITSUB
End If


BlockNr = HexStrToInt(BlockNrText.Text)
DataLen = StrToArray(ucData, 4, DecermentValText.Text)
rc = SCardCLMifareStdDecrementVal(hCard, BlockNr, ucData(LBound(ucData)), DataLen)
If rc = 0 Then
OutPutList.AddItem "Value has been decremented  successfully"
StatusText.Text = " SUCCESS"
End If

If rc <> 0 Then
OutPutList.AddItem "Error in  SCardCLMifareStdDecrementVal"
OutPutList.AddItem HandleError(rc)
StatusText.Text = " ERROR"
End If

EXITSUB:
OutPutList.ListIndex = OutPutList.ListCount - 1
End Sub

Private Sub DisConnectCard_Click()

If fCardConnected = False Then
OutPutList.AddItem "Card is not Connected"
StatusText.Text = " ERROR"
GoTo EXITSUB
End If

 rc = SCardDisconnect(hCard, SCARD_UNPOWER_CARD)
If rc = 0 Then
OutPutList.AddItem "Card has bee disconnected successfully"
fCardConnected = False
ATRText = ""
UIDText = ""
CardNameText = ""
StatusText.Text = " SUCCESS"
End If

If rc <> 0 Then
OutPutList.AddItem "Error in  SCardDisconnect"
OutPutList.AddItem HandleError(rc)
StatusText.Text = " ERROR"

End If

EXITSUB:
OutPutList.ListIndex = OutPutList.ListCount - 1
End Sub

Private Sub Form_Initialize()
Dim rc As Long
Dim dwScope As Long
Dim mszReaders(2048) As Byte
Dim mszGroup(1024) As Byte
Dim pcchReaders As Long
Dim curReader As String
Dim i As Integer
hCard = 0
hContext = 0
fLookForCard = True

' Set Scope (see Scard.bas "Scopes")
dwScope = SCARD_SCOPE_USER

' Establish Context
rc = SCardEstablishContext(dwScope, 0, 0, hContext)

' Set maximum Length of mszReaders
pcchReaders = 2048

' Create a Multistring (terminated with two '\0's)
mszGroup(0) = &H0
mszGroup(1) = &H0

rc = SCardListReaders(hContext, mszGroup(LBound(mszGroup)), mszReaders(LBound(mszReaders)), pcchReaders)
    
ReaderList.Clear


' Split multistring and add single Readers to list
For i = 0 To pcchReaders - 2 Step 1
      curReader = curReader + GetString(mszReaders(i))
    
      If mszReaders(i) = &H0 And i <> 0 Then
        ReaderList.AddItem (curReader)
        curReader = ""
    End If
  
Next i


For i = 0 To ReaderList.ListCount - 1 Step 1
ReaderList.ListIndex = i
If ReaderList.Text = "OMNIKEY CardMan 5121 0" Then
SelectedReader = ReaderList.Text
End If
Next i
   
   
   
End Sub
Private Function HexDump(response() As Byte, ByVal lenr As Long) As String

Dim OUT As String
Dim count As Integer
Dim value As Integer

For count = 0 To lenr - 1 Step 1
    value = response(count)
   
    ifvalue = Fix(value / 16)
    If ifvalue > -1 And ifvalue < 10 Then
        OUT = OUT + String(1, ifvalue + 48)
    Else
        If ifvalue > 9 And ifvalue < 16 Then
            OUT = OUT + String(1, ifvalue + 55)
        End If
    End If
    
    value = Fix(value Mod 16)
        
    If value > -1 And value < 10 Then
        OUT = OUT + String(1, value + 48)
    Else
        If value > 9 And value < 16 Then
            OUT = OUT + String(1, value + 55)
        End If
    End If
     
    OUT = OUT + " "
Next count

HexDump = OUT

End Function
'
' Convert 1 Byte to String
'
Private Function GetString(ByVal curByte As Byte) As String

GetString = String(1, curByte)

End Function

Private Function HexStrToInt(ByVal str As String) As Integer

Dim i As Integer
Dim iTmp As Integer
Dim sTmp As String

iStrLen = Len(str)

iTmp = 0
For i = 1 To Len(str)
    iTmp = iTmp * 16
    sTmp = Mid$(str, i, 1)
    iTmp = iTmp + Switch(sTmp = "A", 10, _
                         sTmp = "a", 10, _
                         sTmp = "B", 11, _
                         sTmp = "b", 11, _
                         sTmp = "C", 12, _
                         sTmp = "c", 12, _
                         sTmp = "D", 13, _
                         sTmp = "d", 13, _
                         sTmp = "E", 14, _
                         sTmp = "e", 14, _
                         sTmp = "F", 15, _
                         sTmp = "f", 15, _
                         1 = 1, sTmp _
                         )
Next

HexStrToInt = iTmp

End Function

Private Function StrToArray(ByRef ucBuffer() As Byte, ByVal BufferLen As Integer, ByVal str As String) As Integer

Dim i As Integer
Dim iStrLen As Integer
Dim iTmp As Integer
Dim sTmp As String
Dim temp(64) As Byte
iStrLen = Len(str)

If (iStrLen Mod 2) <> 0 Then
OutPutList.AddItem "Invalid String"
Exit Function
End If

If BufferLen <> iStrLen / 2 Then
OutPutList.AddItem "Buffer size and string size does not match"
Exit Function
End If

iTmp = 0
For i = 1 To iStrLen
    sTmp = Mid$(str, i, 1)
    iTmp = iTmp + Switch(sTmp = "A", 10, _
                         sTmp = "a", 10, _
                         sTmp = "B", 11, _
                         sTmp = "b", 11, _
                         sTmp = "C", 12, _
                         sTmp = "c", 12, _
                         sTmp = "D", 13, _
                         sTmp = "d", 13, _
                         sTmp = "E", 14, _
                         sTmp = "e", 14, _
                         sTmp = "F", 15, _
                         sTmp = "f", 15, _
                         1 = 1, sTmp _
                         )
  
    If (i Mod 2) = 0 Then
        temp((i / 2)) = iTmp
        iTmp = 0
    End If
    iTmp = iTmp * 16
Next


For i = 0 To BufferLen - 1 Step 1
ucBuffer(i) = temp(i + 1)
Next



StrToArray = iStrLen / 2


End Function

Private Sub iCLASSTransmit_Click()
Dim ucSendData(64) As Byte
Dim lSendDataLen As Long
Dim ucReceivedData(64) As Byte
Dim lReceivedDataLen As Long
Dim iStrLen As Integer

lReceivedDataLen = 64
If fCardConnected = False Then
OutPutList.AddItem " At first Card has to be connected"
StatusText.Text = " ERROR"
GoTo EXITSUB
End If

iStrLen = Len(iCLASSSendText.Text)
lSendDataLen = StrToArray(ucSendData, iStrLen / 2, iCLASSSendText.Text)

rc = SCardCLICCTransmit(hCard, ucSendData(LBound(ucSendData)), lSendDataLen, ucReceivedData(LBound(ucReceivedData)), lReceivedDataLen)
If rc <> 0 Then
OutPutList.AddItem "Error in  SCardCLICCTransmit"
OutPutList.AddItem HandleError(rc)
StatusText.Text = " SUCCESS"
End If

If rc = 0 Then
OutPutList.AddItem "SCardCLICCTransmit has been performed successfully"
StatusText.Text = " SUCCESS"
iCLASSReceivedText = HexDump(ucReceivedData, lReceivedDataLen)
End If







EXITSUB:
End Sub