Attribute VB_Name = "winscard"
Option Explicit

Public Type SCARD_IO_REQUEST
    
    dwProtocol As Long
    cbPciLength As Long

End Type

Global Const SCARD_S_SUCCESS = 0
Global Const SCARD_ATR_LENGTH = 50

Global Const SCARD_SCOPE_USER = 0
Global Const SCARD_SCOPE_TERMINAL = 1
Global Const SCARD_SCOPE_SYSTEM = 2

Global Const SCARD_STATE_UNAWARE = &H0
Global Const SCARD_STATE_IGNORE = &H1
Global Const SCARD_STATE_CHANGED = &H2
Global Const SCARD_STATE_UNKNOWN = &H4
Global Const SCARD_STATE_UNAVAILABLE = &H8
Global Const SCARD_STATE_EMPTY = &H10
Global Const SCARD_STATE_PRESENT = &H20
Global Const SCARD_STATE_ATRMATCH = &H40
Global Const SCARD_STATE_EXCLUSIVE = &H80
Global Const SCARD_STATE_INUSE = &H100
Global Const SCARD_STATE_MUTE = &H200
Global Const SCARD_STATE_UNPOWERED = &H400

Global Const SCARD_SHARE_EXCLUSIVE = 1
Global Const SCARD_SHARE_SHARED = 2
Global Const SCARD_SHARE_DIRECT = 3

Global Const SCARD_LEAVE_CARD = 0
Global Const SCARD_RESET_CARD = 1
Global Const SCARD_UNPOWER_CARD = 2
Global Const SCARD_EJECT_CARD = 3

'Error Codes
Global Const SCARD_F_INTERNAL_ERROR = &H80100001
Global Const SCARD_E_CANCELLED = &H80100002
Global Const SCARD_E_INVALID_HANDLE = &H80100003
Global Const SCARD_E_INVALID_PARAMETER = &H80100004
Global Const SCARD_E_INVALID_TARGET = &H80100005
Global Const SCARD_E_NO_MEMORY = &H80100006
Global Const SCARD_F_WAITED_TOO_LONG = &H80100007
Global Const SCARD_E_INSUFFICIENT_BUFFER = &H80100008
Global Const SCARD_E_UNKNOWN_READER = &H80100009
Global Const SCARD_E_TIMEOUT = &H8010000A
Global Const SCARD_E_SHARING_VIOLATION = &H8010000B
Global Const SCARD_E_NO_SMARTCARD = &H8010000C
Global Const SCARD_E_UNKNOWN_CARD = &H8010000D
Global Const SCARD_E_CANT_DISPOSE = &H8010000E
Global Const SCARD_E_PROTO_MISMATCH = &H8010000F
Global Const SCARD_E_NOT_READY = &H80100010
Global Const SCARD_E_INVALID_VALUE = &H80100011
Global Const SCARD_E_SYSTEM_CANCELLED = &H80100012
Global Const SCARD_F_COMM_ERROR = &H80100013
Global Const SCARD_F_UNKNOWN_ERROR = &H80100014
Global Const SCARD_E_INVALID_ATR = &H80100015
Global Const SCARD_E_NOT_TRANSACTED = &H80100016
Global Const SCARD_E_READER_UNAVAILABLE = &H80100017
Global Const SCARD_P_SHUTDOWN = &H80100018
Global Const SCARD_E_PCI_TOO_SMALL = &H80100019
Global Const SCARD_E_READER_UNSUPPORTED = &H8010001A
Global Const SCARD_E_DUPLICATE_READER = &H8010001B
Global Const SCARD_E_CARD_UNSUPPORTED = &H8010001C
Global Const SCARD_E_NO_SERVICE = &H8010001D
Global Const SCARD_E_SERVICE_STOPPED = &H8010001E
Global Const SCARD_W_UNSUPPORTED_CARD = &H80100065
Global Const SCARD_W_UNRESPONSIVE_CARD = &H80100066
Global Const SCARD_W_UNPOWERED_CARD = &H80100067
Global Const SCARD_W_RESET_CARD = &H80100068
Global Const SCARD_W_REMOVED_CARD = &H80100069

' Protocol
Global Const SCARD_PROTOCOL_UNDEFINED = &H0
Global Const SCARD_PROTOCOL_T0 = &H1
Global Const SCARD_PROTOCOL_T1 = &H2
Global Const SCARD_PROTOCOL_RAW = &H10000
Global Const SCARD_PROTOCOL_DEFAULT = &H80000000


' Reader State
Global Const SCARD_UNKNOWN = 0
Global Const SCARD_ABSENT = 1
Global Const SCARD_PRESENT = 2
Global Const SCARD_SWALLOWED = 3
Global Const SCARD_POWERED = 4
Global Const SCARD_NEGOTIABLE = 5
Global Const SCARD_SPECIFIC = 6

'Buffer size
Global Const NUMBER_OF_READERS = 4
Global Const NAME_LENGTH = 100
Global Const MAX_RESPONSE = 600
Global Const MAX_APDU_BUFFER = 1024

'Error
Global Const ERROR_GENERAL = &HFFFE
Global Const SUCCESS = 36864 '&H9000

'Get Data type
Global Const GET_MIFAREONTE = &H0
Global Const GET_TYPEA_SMART_CARD = &H100
Global Const GET_ULTRALIGHT = &H200
Global Const GET_MIFAREPLUS_L0 = &H300
Global Const GET_MIFAREPLUS_L1 = &H301
Global Const GET_MIFAREPLUS_L2 = &H302
Global Const GET_MIFAREPLUS_L3 = &H303
Global Const GET_MIFAREPLUS_L0S = &H304
Global Const GET_TYPEB_SMART_CARD = &H2000
Global Const GET_SR176 = &H2100
Global Const GET_SRIX4K = &H2200
Global Const GET_AT88F020 = &H2300
Global Const GET_SRI512 = &H2200
Global Const GET_ISO15693 = &H4000
Global Const GET_SAM_1 = &H6000
Global Const GET_SAM_2 = &H6001
Global Const GET_SAM_3 = &H6002
Global Const GET_SAM_4 = &H6003

'Protocol
'  SCARD_PCI_T0       : SCARD_IO_REQUEST = (dwProtocol:1; dbPciLength:8)
'  SCARD_PCI_T1       : SCARD_IO_REQUEST = (dwProtocol:2; dbPciLength:8)


Public Declare Function GetOpenCardNamea Lib "Winscard.dll" (ByVal pDlgStruc As Long) As Long

Public Declare Function SCardEstablishContext Lib "Winscard.dll" (ByVal dwScope As Long, _
                                                                  ByVal pvReserved1 As Long, _
                                                                  ByVal pvReserved2 As Long, _
                                                                  ByRef phContext As Long) As Long
                                                                  
Public Declare Function SCardReleaseContext Lib "Winscard.dll" (ByVal hContext As Long) As Long

Public Declare Function SCardConnect Lib "Winscard.dll" Alias "SCardConnectA" (ByVal hContext As Long, _
                                                                               ByVal szReaderName As String, _
                                                                               ByVal dwShareMode As Long, _
                                                                               ByVal dwPrefProtocol As Long, _
                                                                               ByRef hCard As Long, _
                                                                               ByRef ActiveProtocol As Long) As Long
                                                         
Public Declare Function SCardDisconnect Lib "Winscard.dll" (ByVal hCard As Long, _
                                                            ByVal Disposistion As Long) As Long

Public Declare Function SCardBeginTransaction Lib "Winscard.dll" (ByVal hCard As Long) As Long

Public Declare Function SCardEndTransaction Lib "Winscard.dll" (ByVal hCard As Long, _
                                                                ByVal Disposition As Long) As Long

Public Declare Function SCardState Lib "Winscard.dll" (ByVal hCard As Long, _
                                                       ByRef State As Long, _
                                                       ByRef Protocol As Long, _
                                                       ByRef ATR As Byte, _
                                                       ByRef ATRLen As Long) As Long

Public Declare Function SCardStatus Lib "Winscard.dll" Alias "SCardStatusA" (ByVal hCard As Long, _
                                                                             ByVal szReaderName As String, _
                                                                             ByRef pcchReaderLen As Long, _
                                                                             ByRef State As Long, _
                                                                             ByRef Protocol As Long, _
                                                                             ByRef ATR As Byte, _
                                                                             ByRef ATRLen As Long) As Long

Public Declare Function SCardTransmit Lib "Winscard.dll" (ByVal hCard As Long, _
                                                          pioSendRequest As SCARD_IO_REQUEST, _
                                                          ByRef SendBuff As Byte, _
                                                          ByVal SendBuffLen As Long, _
                                                          pioRecvRequest As SCARD_IO_REQUEST, _
                                                          ByRef RecvBuff As Byte, _
                                                          ByRef RecvBuffLen As Long) As Long
                                                          
Public Declare Function SCardListReaders Lib "Winscard.dll" Alias "SCardListReadersA" (ByVal hContext As Long, _
                                                            ByVal mzGroup As String, _
                                                            ByVal ReaderList As String, _
                                                            ByRef pcchReaders As Long) As Long
                                                            
Public Declare Sub CopyMemory Lib "kernel32 " Alias "RtlMoveMemory " (Destination As Any, Source As Any, ByVal Length As Long)


Public SendRequest As SCARD_IO_REQUEST
Public ReceRequest As SCARD_IO_REQUEST

Public SW1 As Long, SW2 As Long
Public ProtocolType As Long

'变量定义
Dim m_bProtocolType As Integer                         'PC/SC Reader 当前协议
Dim DeviceContext As Long                               'PC/SC Reader 设备描述符
Public m_bReaderCounter As Integer                         'Reader 个数
Public m_bActiveNO As Integer                              '当前激活的Reader是哪一个
Public m_bActiveFlag As Boolean                            '是否有激活Reader
Public ReaderName(0 To NUMBER_OF_READERS) As String        '所有Reader名字
Dim SendAPDU(0 To MAX_APDU_BUFFER) As Byte              '发送APDU Buffer
Dim ReceiveAPDU(0 To MAX_APDU_BUFFER) As Byte           '接收APDU Buffer
Dim hScardHandle As Long                                'Reader 句柄   THandle= Cardinal

Public Sub LoadListToControl(ByVal Ctrl As ComboBox, ByVal ReaderList As String)
   
   Dim TempStr As String
   Dim IndexNum As Integer

     IndexNum = 1
     TempStr = ""
     Ctrl.Clear
     
     While (Mid(ReaderList, IndexNum, 1) <> vbNullChar)
         While (Mid(ReaderList, IndexNum, 1) <> vbNullChar)
             TempStr = TempStr + Mid(ReaderList, IndexNum, 1)
             IndexNum = IndexNum + 1
         Wend
         IndexNum = IndexNum + 1
         Ctrl.AddItem TempStr
         TempStr = ""
     Wend

End Sub


'Updata Reader number
'Return Reader number
Public Function UpdataReader() As Integer

    Dim lReturn, ReaderListSize, i As Integer
    Dim ReaderList As String * 256
    Dim sReaderGroup As String

    'Get PC/SC devicecontext
    m_bActiveFlag = False
    m_bActiveNO = 0
    m_bReaderCounter = 0

    'Is connected
    If (m_bActiveFlag) Then
        'Connected
        lReturn = SCardDisconnect(hScardHandle, SCARD_EJECT_CARD)
        SCardReleaseContext (DeviceContext)
    End If

    'Establish deveice context
    lReturn = SCardEstablishContext(SCARD_SCOPE_USER, 0, 0, DeviceContext)
    If (SCARD_S_SUCCESS = lReturn) Then
       'success：List all device context
        lReturn = SCardListReaders(DeviceContext, sReaderGroup, 0, ReaderListSize)

        If lReturn = SCARD_S_SUCCESS Then
        '   Dim ReaderList As String * ReaderListSize
            lReturn = SCardListReaders(DeviceContext, sReaderGroup, ReaderList, ReaderListSize)
            
            Dim TempStr As String
            Dim IndexNum As Integer

            IndexNum = 1
            TempStr = ""
     
            While (Mid(ReaderList, IndexNum, 1) <> vbNullChar)
                While (Mid(ReaderList, IndexNum, 1) <> vbNullChar)
                    TempStr = TempStr + Mid(ReaderList, IndexNum, 1)
                    IndexNum = IndexNum + 1
                    
                Wend
                m_bReaderCounter = m_bReaderCounter + 1
                ReaderName(i) = TempStr
                TempStr = ""
            Wend
            UpdataReader = m_bReaderCounter
            Exit Function
        End If
    End If
    UpdataReader = 0

End Function

'Connect Reader
Public Function ConnectReader(ReaderNo As Integer) As Boolean

    Dim lReturn As Integer
    Dim ActiveProtocol As Long
    
    'Reader count
    If (m_bReaderCounter < (ReaderNo + 1)) Then
        ConnectReader = False
    End If

    If (m_bActiveFlag = False) Then
        'Connect Reader
        lReturn = SCardDisconnect(hScardHandle, SCARD_EJECT_CARD)
        m_bProtocolType = SCARD_PROTOCOL_T0 Or SCARD_PROTOCOL_T1
        lReturn = SCardConnect(DeviceContext, ReaderName(ReaderNo), SCARD_SHARE_EXCLUSIVE, m_bProtocolType, hScardHandle, ActiveProtocol)
        If (SCARD_S_SUCCESS = lReturn) Then
            m_bProtocolType = ActiveProtocol
            m_bActiveNO = ReaderNo
            m_bActiveFlag = True

            ConnectReader = True
            Exit Function
        End If
    End If
    ConnectReader = False
End Function

'Disconnect reader
Public Function DisconnectReader() As Boolean

    Dim lReturn As Integer
    
    If (m_bActiveFlag) Then
        lReturn = SCardDisconnect(hScardHandle, SCARD_EJECT_CARD)
        If (SCARD_S_SUCCESS <> lReturn) Then
            DisconnectReader = False
            Exit Function
        End If
    End If
    m_bActiveFlag = False
    DisconnectReader = True
End Function


                                                          
'Send APDU
Public Function APDUCommand(APDU() As Byte, ByVal iLen As Long, cReceiveData() As Byte, ByRef iReceiveLen As Integer) As Long

    Dim cReceive(0 To MAX_RESPONSE) As Byte
    Dim lReturn, i As Integer
    Dim SW1, SW2 As Integer
    Dim ReceiveLen As Long
    
    SendRequest.dwProtocol = m_bProtocolType
    SendRequest.cbPciLength = Len(SendRequest)
    ReceRequest.dwProtocol = SCARD_PROTOCOL_T0
    ReceRequest.cbPciLength = Len(ReceRequest)
  
    ReceiveLen = MAX_RESPONSE + 1

    lReturn = SCardTransmit(hScardHandle, SendRequest, APDU(0), iLen, ReceRequest, cReceive(0), ReceiveLen)

    If (lReturn <> SCARD_S_SUCCESS) Then
        iReceiveLen = 0
        APDUCommand = &HFFFF
        Exit Function
    End If
    
    For i = 0 To ReceiveLen - 1
        cReceiveData(i) = cReceive(i)
    Next i
    
    iReceiveLen = ReceiveLen - 2
    SW1 = cReceive(ReceiveLen - 2)
    SW2 = cReceive(ReceiveLen - 1)
    APDUCommand = SW1 * 256& + SW2
End Function

'Get DATA APDU
Public Function GetData(ByVal iCardType As Integer, cReceiveData() As Byte, ByRef iReceiveLen As Integer) As Long

    Dim iSW As Long
    
    iSW = ERROR_GENERAL

    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &HCA
        SendAPDU(2) = (iCardType \ 2 ^ 8) And &HFF
        SendAPDU(3) = iCardType And &HFF
        SendAPDU(4) = &H0

        iSW = APDUCommand(SendAPDU, 5, cReceiveData, iReceiveLen)
    End If
    GetData = iSW
End Function

'Authentication APDU
Public Function Authentication(ByVal iBlockAddr As Integer, ByVal cKeyType As Byte, ByVal cKeyCofig As Byte, cpKeyData() As Byte) As Long

    Dim iSendLen, i As Integer
    Dim iSW As Long
    Dim iReceiveLen As Integer
    
    iSW = ERROR_GENERAL
    iReceiveLen = 0

    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &H88
        SendAPDU(2) = (iBlockAddr \ 2 ^ 8) And &HFF
        SendAPDU(3) = iBlockAddr And &HFF
        SendAPDU(4) = cKeyType
        SendAPDU(5) = cKeyCofig

        If ((cKeyCofig And &H80) <> 0) Then
            'Authentication use saved key in flash
            SendAPDU(6) = cpKeyData
            iSendLen = 7
        Else
            'Authentication use current inputing key
            iSendLen = 6 + cKeyCofig
            For i = 0 To cKeyCofig - 1
                SendAPDU(6 + i) = cpKeyData(i)
            Next i
        End If

        iSW = APDUCommand(SendAPDU, iSendLen, ReceiveAPDU, iReceiveLen)
    End If
    
    Authentication = iSW
End Function

'Read card block
Public Function ReadBinaryBlock(ByVal iBlockAddr As Integer, cReceiveData() As Byte, ByRef iReceiveLen As Integer) As Long

    Dim iSW, i As Long

    iSW = ERROR_GENERAL

    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &HB0
        SendAPDU(2) = (iBlockAddr \ 2 ^ 8) And &HFF
        SendAPDU(3) = iBlockAddr And &HFF
        SendAPDU(4) = iReceiveLen And &HFF

        iSW = APDUCommand(SendAPDU, 5, ReceiveAPDU, iReceiveLen)
        If (SUCCESS = iSW) Then
            For i = 0 To iReceiveLen - 1
                cReceiveData(i) = ReceiveAPDU(i)
            Next i
        End If
    End If

    ReadBinaryBlock = iSW
End Function

'Write card block
Public Function UpdataBinaryBlock(ByVal iBlockAddr As Integer, cSendData() As Byte, ByVal iDataLen As Integer) As Long

    Dim iSendLen, i As Integer
    Dim iSW As Long
    Dim iReceiveLen As Integer

    iSW = ERROR_GENERAL
    iReceiveLen = 0
    
    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &HD6
        SendAPDU(2) = (iBlockAddr \ 2 ^ 8) And &HFF
        SendAPDU(3) = iBlockAddr And &HFF
        SendAPDU(4) = iDataLen And &HFF
        For i = 0 To iDataLen - 1
            SendAPDU(5 + i) = cSendData(i)
        Next i
        
        iSendLen = 5 + iDataLen
        
        iSW = APDUCommand(SendAPDU, iSendLen, ReceiveAPDU, iReceiveLen)
    End If

    UpdataBinaryBlock = iSW
End Function

'Value operation: Initialize purse(00), increase purse(01), decrease purse(02)
Public Function ValueBlockOperation(ByVal iBlockAddr As Integer, ByVal cOperateType As Byte, ByRef iValue As Long) As Long

    Dim iReceiveLen As Integer
    Dim iSW As Long

    iSW = ERROR_GENERAL
    iReceiveLen = 0

    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &HD7
        SendAPDU(2) = (iBlockAddr / 256) And &HFF
        SendAPDU(3) = iBlockAddr And &HFF
        SendAPDU(4) = &H5
        SendAPDU(5) = cOperateType
        SendAPDU(9) = (iValue / 2 ^ 24) And &HFF
        SendAPDU(8) = (iValue / 2 ^ 16) And &HFF
        SendAPDU(7) = (iValue / 2 ^ 8) And &HFF
        SendAPDU(6) = iValue And &HFF
        
        iSW = APDUCommand(SendAPDU, 10, ReceiveAPDU, iReceiveLen)
    End If
    
    ValueBlockOperation = iSW
End Function

'read purse
Public Function ReadValueBlock(ByVal iBlockAddr As Integer, ByRef iValue As Long) As Long

    Dim i As Integer
    Dim iReceiveLen As Integer
    Dim iSW As Long

    iSW = ERROR_GENERAL
    iReceiveLen = 0
    
    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &HB1
        SendAPDU(2) = (iBlockAddr \ 8) And &HFF
        SendAPDU(3) = iBlockAddr And &HFF
        SendAPDU(4) = &H4
        
        iSW = APDUCommand(SendAPDU, 5, ReceiveAPDU, iReceiveLen)
        If (SUCCESS = iSW) Then
            iValue = ReceiveAPDU(0) * 2 ^ 24 + ReceiveAPDU(1) * 2 ^ 16 + ReceiveAPDU(2) * 2 ^ 8 + ReceiveAPDU(0)
        End If
    End If

    ReadValueBlock = iSW
End Function

'backup purse
Public Function RestoreValueBlock(ByVal iSrcAddr As Integer, ByVal iTargetAddr As Integer) As Long

    Dim iReceiveLen As Integer
    Dim iSW As Long
    iSW = ERROR_GENERAL
    iReceiveLen = 0
    
    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &HD7
        SendAPDU(2) = (iSrcAddr \ 256) And &HFF
        SendAPDU(3) = iSrcAddr And &HFF
        SendAPDU(4) = &H3
        SendAPDU(5) = &H3
        SendAPDU(6) = (iTargetAddr \ 256) And &HFF
        SendAPDU(7) = iTargetAddr And &HFF

        iSW = APDUCommand(SendAPDU, 8, ReceiveAPDU, iReceiveLen)
    End If

    RestoreValueBlock = iSW
End Function

'TypeA card Halt
Public Function TypeA_Halt() As Long
    Dim iSW, iReceiveLen As Integer
    
    iSW = ERROR_GENERAL
    iReceiveLen = 0

    If (m_bActiveFlag) Then
        SendAPDU(0) = &HFF
        SendAPDU(1) = &H0
        SendAPDU(2) = &H0
        SendAPDU(3) = &H1
        SendAPDU(4) = &H0

        iSW = APDUCommand(SendAPDU, 5, ReceiveAPDU, iReceiveLen)
    End If

    TypeA_Halt = iSW
End Function

