rfid passport.frm

an example of programming philips pegoda reader

      Begin VB.Label lblHex 
         Caption         =   "HEX:"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   360
         TabIndex        =   5
         Top             =   3000
         Width           =   1575
      End
      Begin VB.Label lblASCII 
         Caption         =   "ASCII:"
         BeginProperty Font 
            Name            =   "MS Sans Serif"
            Size            =   8.25
            Charset         =   0
            Weight          =   700
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   360
         TabIndex        =   2
         Top             =   3480
         Width           =   735
      End
   End
End
Attribute VB_Name = "frmMifareExample"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cboBlock_Click()
    gBlock = CByte(Me.cboBlock.Text)
End Sub

Private Sub cmdCommands_Click(Index As Integer)
    Dim status As Integer
    Dim mystr As String
    Dim i As Byte
    
    Select Case Index
        Case 0:     ' Request
            If Mf500PiccRequest(&H52, gtt(0)) <> MI_OK Then
                lblStatus.Caption = "Error Activating Card!"
            Else
                lblStatus.Caption = "Request Successful."
            End If
        Case 1:     ' Read
            If Mf500PiccRead(gBlock, gdata(0)) <> MI_OK Then
                lblStatus.Caption = "Error Reading Card!"
            Else
                status = CArrayHex(mystr, gdata)
                Me.txtData(0).Text = mystr
                status = CArrayStr(mystr, gdata)
                Me.txtData(1).Text = mystr
                lblStatus.Caption = "Read Card Successful."
            End If
        Case 2:     ' Write
            PrepareWrVal
            If Mf500PiccWrite(gBlock, gdata(0)) <> MI_OK Then
                lblStatus.Caption = "Error Writing Card!"
            Else
                lblStatus.Caption = "Write Card Successful."
            End If
        Case 3:     ' Anticollision
            If Mf500PiccAnticoll(0, uid(0)) <> MI_OK Then
                lblStatus.Caption = "Error Anticollision!"
            Else
                mystr = ""
                For i = 0 To 3
                    mystr = mystr + Hex(uid(i))
                Next
                lblStatus.Caption = "Anticollision Successful. " + "S/N: " + mystr
            End If
        Case 4:     ' Select
            If Mf500PiccSelect(uid(0), sak) <> MI_OK Then
                lblStatus.Caption = "Error Anticollision!"
            Else
                lblStatus.Caption = "Select Successful. "
            End If
        Case 5:     ' Authenticate
            status = Mf500HostCodeKey(keyF(0), gkeyCoded(0))
            If Mf500PiccAuthKey(&H60, uid(0), gkeyCoded(0), gBlock) <> MI_OK Then
                lblStatus.Caption = "Error Authenticating Block" + str(gBlock) + "!"
            Else
                lblStatus.Caption = "Authenticating Successful."
            End If
        Case 6:     ' RF Reset
            PcdRfReset (10)
            lblStatus.Caption = "RF Reset Successful."
        Case 7:     ' Activate Idle
            If (Mf500PiccActivateIdle(0, atq(0), sak, uid(0), uid_len) <> MI_OK) Then
                lblStatus.Caption = "Error Activating Card!"
            Else
                mystr = ""
                For i = 0 To 3
                    mystr = mystr + Hex(uid(i))
                Next
                lblStatus.Caption = "Activate Idle Successful. " + "S/N: " + mystr
            End If
    End Select
End Sub

Private Sub cmdExit_Click()
    End
End Sub
Private Sub cmdPort_Click(Index As Integer)
    Dim status As Integer
    Dim i As Byte
    
    Select Case Index
        Case 0:
            If (Mf500InterfaceOpen(USB, 0&) = MI_POLLING) Then
                status = Mf500PcdConfig()
                Do While (status <> MI_OK)
                    status = Mf500PcdConfig()
                Loop
                For i = 0 To 7
                    Me.cmdCommands(i).Enabled = True
                Next
                lblStatus.Caption = "USB Reader Interface Successful!"
                cmdPort(0).Enabled = False
                cmdPort(1).Enabled = True
            Else
                lblStatus.Caption = "USB Reader Interface Failure!"
                cmdPort(1).Enabled = False
            End If
        Case 1:
            Mf500InterfaceClose
            For i = 0 To 7
                Me.cmdCommands(i).Enabled = False
            Next
            cmdPort(0).Enabled = True
            cmdPort(1).Enabled = False
    End Select
End Sub

Private Sub Form_Load()
    Dim i As Byte
    Dim mystr As String
    
    For i = 0 To 63
        mystr = ""
        If i < 10 Then
            mystr = "0"
        End If
        If i Mod 4 = 3 Then
            mystr = mystr + "00"
        End If
        mystr = mystr + CStr(i)
        Me.cboBlock.AddItem (mystr)
    Next
    For i = 0 To 7
        Me.cmdCommands(i).Enabled = False
    Next
    For i = 0 To 5
        keyF(i) = &HFF
    Next
End Sub

Private Sub Form_Terminate()
        Mf500InterfaceClose
End Sub

Function CArrayStr(ByRef str, ByRef data) As Byte
    Dim char As String
    Dim count As Byte
    
    str = ""
    For count = 0 To 15
        str = str + Chr(data(count))
        If data(count) = 0 Then
            Exit Function
        End If
    Next
End Function
Function CArrayHex(ByRef mystr, ByRef data) As Byte
    Dim char As String
    Dim count As Byte
    
    mystr = ""
    For count = 0 To 15
        If data(count) < 16 Then
            mystr = mystr + "0"
        End If
        mystr = mystr + (Hex(data(count)))
    Next
End Function

Function CStrAscii(ByRef mystr, ByRef hexstr) As Byte
    Dim i As Byte
    Dim tempstr As String
    
    If Len(mystr) = 0 Then
        hexstr = "00000000000000000000000000000000"
        Exit Function
    End If
    hexstr = ""
    For i = 1 To 16
        If i > Len(mystr) Then
            hexstr = hexstr + "00"
        Else
            tempstr = Mid(mystr, i, 1)
            hexstr = hexstr + Hex(Asc(tempstr)) 'Left(mystr, i + 1)))
        End If
    Next
End Function
Function CHexAscii(ByRef hexstr, ByRef mystr) As Byte
    Dim i As Byte
    Dim temstr As String
    
    mystr = ""
    For i = 1 To Len(hexstr) Step 2
        mystr = mystr + Chr(ConvertHex(Mid(hexstr, i, 2)))
    Next
End Function
Function ConvertHex(str As String) As Byte
    Dim a, b
    
    a = Left(str, 1)
    b = Right(str, 1)
    ConvertHex = CHex(a) * 16 + CHex(b)
End Function
Function CHex(ByVal str As String) As Byte
    Dim ascval
    
    ascval = Asc(str)
    If ((ascval >= 48) And (ascval <= 57)) Then         ' 0 to 9
        CHex = ascval - 48
    ElseIf ((ascval >= 65) And (ascval <= 70)) Then     ' A to F
        CHex = ascval - 55
    End If
End Function

Private Sub txtData_KeyUp(Index As Integer, KeyCode As Integer, Shift As Integer)
    Dim status As Byte
    Dim mystr As String
    
    If Shift = 0 Then
    Select Case Index
        Case 0:     ' Hex
            mystr = Format(Right(txtData(0).Text, 1), ">")
            If ((mystr >= "A") And (mystr <= "F")) Or ((mystr >= "0") And (mystr <= "9")) Then
                If (Len(txtData(0).Text) Mod 2) = 0 Then
                    status = CHexAscii(Format(txtData(0).Text, ">"), mystr)
                    txtData(1).Text = mystr
                End If
            Else
                If Len(txtData(0).Text) > 0 Then
                    txtData(0).Text = Left(txtData(0).Text, Len(txtData(0).Text) - 1)
                Else
                    txtData(1).Text = ""
                End If
            End If
        Case 1:     ' ASCII
            status = CStrAscii(txtData(1).Text, mystr)
            txtData(0).Text = mystr
    End Select
End If

End Sub

Sub PrepareWrVal()
    Dim i, count As Byte
    
    For i = 0 To 15
        gdata(i) = 0
    Next
    count = 0
    For i = 1 To Len(txtData(0).Text) Step 2
        gdata(count) = ConvertHex(Mid(Format(txtData(0).Text, ">"), i, 2))
        count = count + 1
    Next
    
End Sub