ExcelでICカードを読む - エクセリブクラウド

Excel VBAでICカード(Felica)を読み込むサンプル

Excel VBAでICカード(Felica)を読込むサンプルです。外部ライブラリは使っていませんので、何かインストールする必要はありません。

【ご注意】

個人利用／商用問わず、自由にお使いいただけますが、不具合等の一切の理由を問わず、サポートについては別途有償対応とさせていただきます。また、著作権は放棄しておりません。
SONY製 RC-S380で動作確認しています。旧版のカードリーダではおそらく動作しません。
TypeB（マイナンバーカード等）の場合は乱数値(PUPI)を返すので、実質、使えません。。。

使用方法

VBEを開き、標準モジュールに下記コードを設定します。

'' Copyright © 2022 TK-Agile,Inc. All rights reserved.
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 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 SCardDisconnect Lib "winscard.dll" ( _
        ByVal hCard As LongPtr, _
        ByVal Disposition As Long) 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 SCardTransmit Lib "winscard.dll" ( _
        ByVal hCard As LongPtr, _
        ByRef pioSendRequest As SCARD_IO_REQUEST, _
        ByRef sendbuff As Byte, _
        ByVal SendBuffLen As Long, _
        ByRef pioRecvRequest As SCARD_IO_REQUEST, _
        ByRef RecvBuff As Byte, _
        ByRef RecvBuffLen As Long) As LongPtr

Private Type SCARD_READSTATE
    szReader As String
    pvUserData As LongPtr
    dwCurrentState As LongPtr
    dwEventState As LongPtr
    cbAtr As LongPtr
    rgbAtr(36) As Byte
End Type

Private Type SCARD_IO_REQUEST
    dwProtocol As Long
    cbPciLength As Long
End Type

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 hContext As LongPtr
Private readerState As SCARD_READSTATE

'' *********************
'' 関数本体
'' *********************

'' Windows標準APIなので、外部ライブラリなくても動きます
''  ・エラーの場合、ERROR:で始まるメッセージを返す
''  　正常読込の場合、UIDを返す
''  ・カードリーダは、SONY RC-S380のみ動作確認
''  ・TypeBの場合は乱数値(PUPI)を返すので、実用は無理

Public Function readUID() As String

Const SCARD_SCOPE_USER As Integer = 0
 
    Dim ret As LongPtr
    Dim pcchReaders As Long
    Dim mszReaders As String
    Dim readerArray() As String

ret = SCardEstablishContext(SCARD_SCOPE_USER, 0, 0, hContext)
    If ret <> 0 Then
        readUID = "ERROR:初期化処理に失敗しました！"
        Exit Function
    End If
  
    pcchReaders = 256

If readerState.szReader = "" Then
       '文字列サイズ取得
       ret = SCardListReaders(hContext, vbNullString, mszReaders, pcchReaders)
       If ret <> 0 Then
           readUID = "ERROR:カードリーダが見つかりません！"
           Exit Function
       End If
    
       'リーダー名称取得
       mszReaders = String$(pcchReaders, vbNullChar)
       ret = SCardListReaders(hContext, vbNullString, mszReaders, pcchReaders)
       If ret <> 0 Then
           readUID = "ERROR:カードリーダが見つかりません！"
           Exit Function
       End If
    
       readerArray = Split(mszReaders, vbNullChar)
       readerState.dwCurrentState = 0
       readerState.szReader = readerArray(0)
       
       ''Debug.Print "Reader -> "
       ''Debug.Print readerState.szReader
    End If

Dim hCard As LongPtr
    Dim activeProtocol As Long

'カード通信処理
    ret = SCardConnectA(hContext, readerState.szReader, SCARD_SHARE_SHARED, SCARD_PROTOCOL_T1, hCard, activeProtocol)
    If ret <> 0 Then
        readUID = "ERROR:正しいカードをセットしてください！"
        Exit Function
    End If
                      
    Dim sendBuffer(4) As Byte
    Dim recvBuffer(255) As Byte
    Dim recvLen As Long
    Dim ioSendReq As SCARD_IO_REQUEST
    Dim ioRecvReq As SCARD_IO_REQUEST
 
    ioSendReq.dwProtocol = activeProtocol
    ioSendReq.cbPciLength = Len(ioSendReq)
    ioRecvReq.dwProtocol = activeProtocol
    ioRecvReq.cbPciLength = Len(ioSendReq)
 
    '送信バッファ
    sendBuffer(0) = &HFF
    sendBuffer(1) = &HCA
    sendBuffer(2) = &H0
    sendBuffer(3) = &H0
    sendBuffer(4) = &H0
    
    'データ受信
    recvLen = 255
    ret = SCardTransmit(hCard, ioSendReq, sendBuffer(0), 5, ioRecvReq, recvBuffer(0), recvLen)
    If ret <> 0 Then
        readUID = "ERROR:ID取得エラー(Transmit:" & Hex(ret) & ")"
        GoTo ExitProc
    End If
 
    'データチェック
    If recvBuffer(recvLen - 2) <> &H90 Then
        readUID = "ERROR:ID取得エラー（読込異常：" & Hex(recvBuffer(0)) & "," & Hex(recvBuffer(1)) & ")"
        GoTo ExitProc
    End If

ExitProc:

'カード切断処理
    ret = SCardDisconnect(hCard, SCARD_LEAVE_CARD)
    If ret <> 0 Then
        MsgBox ("ERROR:切断エラー " + Hex(ret))
        Exit Function
    End If
 
    '読込データセット
    Dim cardData As String
    Dim i As Long
    cardData = ""
    ''For i = 0 To 8
    ''    If Chr(recvBuffer(i)) <> Space(1) Then
    ''        cardData = cardData & Hex(recvBuffer(i))
    ''        '' Debug.Print Format(i, "00") & ":"; recvBuffer(i) & ":" & Hex(recvBuffer(i))
    ''    End If
    ''Next

'' 2024.1.23 カードID読取り不具合修正
    For i = 0 To 7
        If Chr(recvBuffer(i)) <> Space(1) Then
            cardData = cardData & Right("0" & Hex(recvBuffer(i)), 2)
            '' Debug.Print Format(i, "00") & ":"; recvBuffer(i) & ":" & Hex(recvBuffer(i))
        End If
    Next

'' Debug.Print cardData
 
    readUID = cardData
    
End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

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 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 SCardDisconnect Lib "winscard.dll" ( _

ByVal hCard As LongPtr, _

ByVal Disposition As Long) 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 SCardTransmit Lib "winscard.dll" ( _

ByVal hCard As LongPtr, _

ByRef pioSendRequest As SCARD_IO_REQUEST, _

ByRef sendbuff As Byte, _

ByVal SendBuffLen As Long, _

ByRef pioRecvRequest As SCARD_IO_REQUEST, _

ByRef RecvBuff As Byte, _

ByRef RecvBuffLen As Long) As LongPtr

Private Type SCARD_READSTATE

szReader As String

pvUserData As LongPtr

dwCurrentState As LongPtr

dwEventState As LongPtr

cbAtr As LongPtr

rgbAtr(36) As Byte

End Type

Private Type SCARD_IO_REQUEST

dwProtocol As Long

cbPciLength As Long

End Type

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 hContext As LongPtr

Private readerState As SCARD_READSTATE

'' *********************

'' 関数本体

'' *********************

'' Windows標準APIなので、外部ライブラリなくても動きます

'' ・エラーの場合、ERROR:で始まるメッセージを返す

'' 　正常読込の場合、UIDを返す

'' ・カードリーダは、SONY RC-S380のみ動作確認

'' ・TypeBの場合は乱数値(PUPI)を返すので、実用は無理

Public Function readUID() As String

Const SCARD_SCOPE_USER As Integer = 0

Dim ret As LongPtr

Dim pcchReaders As Long

Dim mszReaders As String

Dim readerArray() As String

ret = SCardEstablishContext(SCARD_SCOPE_USER, 0, 0, hContext)

If ret <> 0 Then

readUID = "ERROR:初期化処理に失敗しました！"

Exit Function

End If

pcchReaders = 256

If readerState.szReader = "" Then

'文字列サイズ取得

ret = SCardListReaders(hContext, vbNullString, mszReaders, pcchReaders)

If ret <> 0 Then

readUID = "ERROR:カードリーダが見つかりません！"

Exit Function

End If

'リーダー名称取得

mszReaders = String$(pcchReaders, vbNullChar)

ret = SCardListReaders(hContext, vbNullString, mszReaders, pcchReaders)

If ret <> 0 Then

readUID = "ERROR:カードリーダが見つかりません！"

Exit Function

End If

readerArray = Split(mszReaders, vbNullChar)

readerState.dwCurrentState = 0

readerState.szReader = readerArray(0)

''Debug.Print "Reader -> "

''Debug.Print readerState.szReader

End If

Dim hCard As LongPtr

Dim activeProtocol As Long

'カード通信処理

ret = SCardConnectA(hContext, readerState.szReader, SCARD_SHARE_SHARED, SCARD_PROTOCOL_T1, hCard, activeProtocol)

If ret <> 0 Then

readUID = "ERROR:正しいカードをセットしてください！"

Exit Function

End If

Dim sendBuffer(4) As Byte

Dim recvBuffer(255) As Byte

Dim recvLen As Long

Dim ioSendReq As SCARD_IO_REQUEST

Dim ioRecvReq As SCARD_IO_REQUEST

ioSendReq.dwProtocol = activeProtocol

ioSendReq.cbPciLength = Len(ioSendReq)

ioRecvReq.dwProtocol = activeProtocol

ioRecvReq.cbPciLength = Len(ioSendReq)

'送信バッファ

sendBuffer(0) = &HFF

sendBuffer(1) = &HCA

sendBuffer(2) = &H0

sendBuffer(3) = &H0

sendBuffer(4) = &H0

'データ受信

recvLen = 255

ret = SCardTransmit(hCard, ioSendReq, sendBuffer(0), 5, ioRecvReq, recvBuffer(0), recvLen)

If ret <> 0 Then

readUID = "ERROR:ID取得エラー(Transmit:" & Hex(ret) & ")"

GoTo ExitProc

End If

'データチェック

If recvBuffer(recvLen - 2) <> &H90 Then

readUID = "ERROR:ID取得エラー（読込異常：" & Hex(recvBuffer(0)) & "," & Hex(recvBuffer(1)) & ")"

GoTo ExitProc

End If

ExitProc:

'カード切断処理

ret = SCardDisconnect(hCard, SCARD_LEAVE_CARD)

If ret <> 0 Then

MsgBox ("ERROR:切断エラー " + Hex(ret))

Exit Function

End If

'読込データセット

Dim cardData As String

Dim i As Long

cardData = ""

''For i = 0 To 8

'' If Chr(recvBuffer(i)) <> Space(1) Then

'' cardData = cardData & Hex(recvBuffer(i))

'' '' Debug.Print Format(i, "00") & ":"; recvBuffer(i) & ":" & Hex(recvBuffer(i))

'' End If

''Next

'' 2024.1.23 カードID読取り不具合修正

For i = 0 To 7

If Chr(recvBuffer(i)) <> Space(1) Then

cardData = cardData & Right("0" & Hex(recvBuffer(i)), 2)

'' Debug.Print Format(i, "00") & ":"; recvBuffer(i) & ":" & Hex(recvBuffer(i))

End If

'' Debug.Print cardData

readUID = cardData

End Function

readUID関数を呼び出し、ICカードのUIDを取得します。

たとえば、イミディエイトウインドウで「? readUID」

以上

その他のサポートが必要な方はこちらから

オンサイト教育実施、exce.liveクラウドを使った業務マクロ開発サポート等、お客様のご要望に合わせたサポートが可能です（有償）
その他、軽微なお問合せはtwitter(@excelive)でも受け付けます。

お問合せは下記メールまたは右のボタンからinfo@exce.live

フォームでお問い合わせお気軽にお問い合わせください