【VBA】FelicaのUIDを読み取りExcelに出力する

Option Explicit

' *********************
'  API宣言
' *********************
Private Declare PtrSafe Function SCardEstablishContext Lib "winscard.dll" ( _
        ByVal dwScope As Long, _
        ByVal pvReserved1 As Long, _
        ByVal pvReserved2 As Long, _
        ByRef phContext As LongPtr) As LongPtr

Private Declare PtrSafe Function SCardListReaders Lib "winscard.dll" Alias "SCardListReadersA" ( _
        ByVal hContext As LongPtr, _
        ByVal mzGroup As String, _
        ByVal ReaderList As String, _
        ByRef pcchReaders As Long) As LongPtr

Private Declare PtrSafe Function SCardConnectA Lib "winscard.dll" ( _
        ByVal hContext As LongPtr, _
        ByVal szReaderName As String, _
        ByVal dwShareMode As Long, _
        ByVal dwPrefProtocol As Long, _
        ByRef hCard As LongPtr, _
        ByRef activeProtocol As Long) As LongPtr

Private Declare PtrSafe Function SCardTransmit Lib "winscard.dll" ( _
        ByVal hCard As LongPtr, _
        ByRef pioSendRequest As Any, _
        ByRef sendbuff As Byte, _
        ByVal SendBuffLen As Long, _
        ByRef pioRecvRequest As Any, _
        ByRef RecvBuff As Byte, _
        ByRef RecvBuffLen As Long) As LongPtr

Private Declare PtrSafe Function SCardDisconnect Lib "winscard.dll" ( _
        ByVal hCard As LongPtr, _
        ByVal Disposition As Long) As LongPtr

Private Declare PtrSafe Function SCardReleaseContext Lib "winscard.dll" ( _
        ByVal hContext As LongPtr) As LongPtr

' *********************
' 定数の定義
' *********************
Private Const SCARD_SCOPE_USER As Long = 0
Private Const SCARD_SHARE_SHARED As Long = 2
Private Const SCARD_PROTOCOL_T1 As Long = 2
Private Const SCARD_LEAVE_CARD As Long = 0
Private Const MAX_READER_NAME As Long = 256
Private Const MAX_RECEIVE_BUFFER As Long = 255

' *********************
' エラーメッセージの定義
' *********************
Private Const ERR_INIT_FAILED As String = "ERROR:初期化処理に失敗しました。"
Private Const ERR_NO_READER As String = "ERROR:カードリーダが見つかりません。"
Private Const ERR_NO_CARD As String = "ERROR:正しいカードをセットしてください。"
Private Const ERR_TRANSMIT As String = "ERROR:ID取得エラー(Transmit:{0})"
Private Const ERR_READ_ABNORMAL As String = "ERROR:ID取得エラー（読込異常：{0},{1}）"
Private Const ERR_DISCONNECT As String = "ERROR:切断エラー {0}"

' *********************
' 関数本体
' *********************
Public Function ReadUID() As String
    Dim hContext As LongPtr
    Dim readerName As String
    Dim result As String
    
    ' コンテキストを確立
    result = EstablishContext(hContext)
    If Left(result, 5) = "ERROR" Then
        ReadUID = result
        Exit Function
    End If
    
    ' カードリーダーを取得
    result = GetReader(hContext, readerName)
    If Left(result, 5) = "ERROR" Then
        ReadUID = result
        Exit Function
    End If
    
    ' カードに接続してUIDを読み取る
    result = ConnectAndReadCard(hContext, readerName)
    
    ' コンテキストを解放
    Call SCardReleaseContext(hContext)
    
    ReadUID = result
End Function

Private Function EstablishContext(ByRef hContext As LongPtr) As String
    Dim ret As LongPtr
    
    ret = SCardEstablishContext(SCARD_SCOPE_USER, 0, 0, hContext)
    If ret <> 0 Then
        EstablishContext = ERR_INIT_FAILED
    Else
        EstablishContext = "SUCCESS"
    End If
End Function

Private Function GetReader(ByVal hContext As LongPtr, ByRef readerName As String) As String
    Dim ret As LongPtr
    Dim pcchReaders As Long
    Dim mszReaders As String
    Dim readerArray() As String
    
    pcchReaders = MAX_READER_NAME
    
    ' リーダー名称取得
    mszReaders = String$(pcchReaders, vbNullChar)
    ret = SCardListReaders(hContext, vbNullString, mszReaders, pcchReaders)
    If ret <> 0 Then
        GetReader = ERR_NO_READER
        Exit Function
    End If
    
    readerArray = Split(mszReaders, vbNullChar)
    readerName = readerArray(0)
    
    GetReader = "SUCCESS"
End Function

Private Function ConnectAndReadCard(ByVal hContext As LongPtr, ByVal readerName As String) As String
    Dim hCard As LongPtr
    Dim activeProtocol As Long
    Dim ret As LongPtr
    Dim sendBuffer(4) As Byte
    Dim recvBuffer(MAX_RECEIVE_BUFFER - 1) As Byte
    Dim recvLen As Long
    Dim i As Long
    Dim cardData As String
    
    ' カード接続
    ret = SCardConnectA(hContext, readerName, SCARD_SHARE_SHARED, SCARD_PROTOCOL_T1, hCard, activeProtocol)
    If ret <> 0 Then
        ConnectAndReadCard = ERR_NO_CARD
        Exit Function
    End If
    
    ' 送信バッファ設定
    sendBuffer(0) = &HFF: sendBuffer(1) = &HCA: sendBuffer(2) = &H0: sendBuffer(3) = &H0: sendBuffer(4) = &H0
    
    ' データ受信
    recvLen = MAX_RECEIVE_BUFFER
    ret = SCardTransmit(hCard, ByVal 0&, sendBuffer(0), 5, ByVal 0&, recvBuffer(0), recvLen)
    If ret <> 0 Then
        ConnectAndReadCard = Replace(ERR_TRANSMIT, "{0}", Hex(ret))
        GoTo DisconnectCard
    End If
    
    ' データチェック
    If recvBuffer(recvLen - 2) <> &H90 Then
        ConnectAndReadCard = Replace(Replace(ERR_READ_ABNORMAL, "{0}", Hex(recvBuffer(0))), "{1}", Hex(recvBuffer(1)))
        GoTo DisconnectCard
    End If
    
    ' UIDの取得
    cardData = ""
    For i = 0 To 7
        If Chr(recvBuffer(i)) <> Space(1) Then
            cardData = cardData & Right("0" & Hex(recvBuffer(i)), 2)
        End If
    Next i
    
    ConnectAndReadCard = cardData

DisconnectCard:
    ' カード切断
    ret = SCardDisconnect(hCard, SCARD_LEAVE_CARD)
    If ret <> 0 Then
        ConnectAndReadCard = Replace(ERR_DISCONNECT, "{0}", Hex(ret))
    End If
End Function