VB6.0でのSmartCardのサンプルがなかったので作成
ICカードリーダーライターはSony製のRC-S380を使用
サンプルはICカードに16ケタのデータを読み書きするもの
下記からプログラム（長いため，メモ帳などにコピー推奨）
--------------------------------------------------------------------------------
'Private Declare Function FunctionName Lib "WinSCard.dll" ()
'SCardEstablishContext
Private Declare Function SCardEstablishContext Lib "WinScard.dll" ( _
ByVal dwScope As Long, _
ByVal pvReserved1 As Integer, _
ByVal pvReserved2 As Integer, _
ByRef phContext As Long) As Long
'SCardReleaseContext
Private Declare Function SCardReleaseContext Lib "WinScard.dll" ( _
ByVal hContext As Long) As Long
' SCardConnect
Private 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
'SCardDisconnect
Private Declare Function SCardDisconnect Lib "WinScard.dll" ( _
ByVal hCard As Long, _
ByVal Disposition As Integer) As Long
'ScardGetAttrib
Private Declare Function SCardGetAttrib Lib "WinScard.dll" ( _
ByVal hCard As Integer, _
ByVal AttrId As Long, _
ByRef RecvBuff As Byte, _
ByRef RecvBuffLen As Integer) As Long
'SCardListReaders
Private 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
'SCardStatus
Private Declare Function SCardStatus Lib "WinScard.dll" ( _
ByVal hCard As Integer, _
ByVal szReaderName As String, _
ByRef pcchReaderLen As Integer, _
ByRef State As Integer, _
ByRef Protocol As Long, _
ByVal ATR As Byte, _
ByRef ATRLen As Integer) As Long
'SCardTransmit(データの送受信)
Private Declare Function SCardTransmit Lib "WinScard.dll" ( _
ByVal hCard As Long, _
ByRef pioSendRequest As SCARD_IO_REQUEST, _
ByRef sendbuff As Byte, _
ByVal SendBuffLen As Integer, _
ByRef pioRecvRequest As SCARD_IO_REQUEST, _
ByRef RecvBuff As Byte, _
ByRef RecvBuffLen As Integer) As Long
'SCardGetStatusChange
Private Declare Function SCardGetStatusChange Lib "WinScard.dll" Alias "SCardGetStatusChangeA" ( _
ByVal hContext As Long, _
ByVal dwTimeout As Long, _
ByRef readState As SCARD_READSTATE, _
ByVal cReaders As Long) As Long
Private Type SCARD_READSTATE
szReader As String
pvUserData As Long
dwCurrentState As Long
dwEventState As Long
cbAtr As Long
rgbAtr(36) As Byte
End Type
Private Type SCARD_IO_REQUEST
dwProtocol As Long
cbPciLength As Long
End Type
Const SCARD_E_TIMEOUT As Long = "&H8010000A"
Const SCARD_E_NO_READERS_AVAILABLE As Long = "&H8010002E"
Const SCARD_STATE_EMPTY As Long = "&H0010"
Const SCARD_STATE_PRESENT As Long = "&H0020"
Const SCARD_SHARE_SHARED As Integer = 2
Const SCARD_PROTOCOL_T1 As Integer = 2
Const SCARD_LEAVE_CARD As Integer = 0
Dim hContext As Long
Dim readerState As SCARD_READSTATE
'フォームロード時
Private Sub Form_Load()
Const SCARD_SCOPE_USER As Integer = 0
Dim ret As Long
ret = SCardEstablishContext(SCARD_SCOPE_USER, 0, 0, hContext)
If ret <> 0 Then
MsgBox ("Error1:" + CStr(ret))
Exit Sub
End If
Dim pcchReaders As Long
Dim mszReaders As String
Dim readerArray() As String
pcchReaders = 256
'文字列サイズ取得
ret = SCardListReaders(hContext, vbNullString, mszReaders, pcchReaders)
If ret <> 0 Then
MsgBox ("Error2:" + Hex(ret))
Exit Sub
End If
'リーダー名称取得
mszReaders = String$(pcchReaders, vbNullChar)
ret = SCardListReaders(hContext, vbNullString, mszReaders, pcchReaders)
If ret <> 0 Then
MsgBox ("Error3:" + Hex(ret))
Exit Sub
End If
'名称を配列にセット
readerArray = Split(mszReaders, vbNullChar)
'リーダー情報にセット
readerState.dwCurrentState = 0
readerState.szReader = readerArray(0)
Timer1.Enabled = True
End Sub
'フォームアンロード時
Private Sub Form_Unload(Cancel As Integer)
Call SCardReleaseContext(hContext)
End Sub
'書き込みボタン押下
Private Sub cndWrite_Click()
Call writeData
End Sub
'カードリーダータイマー
Private Sub Timer1_Timer()
Dim ret As Long
Timer1.Enabled = False
'ステータスチェック
ret = SCardGetStatusChange(hContext, 100, readerState, 1)
readerState.dwCurrentState = readerState.dwEventState
If ret = SCARD_E_NO_READERS_AVAILABLE Then
lblStatus.Caption = "カードリーダー未接続"
cmdReStart.Visible = True
Exit Sub
End If
If ret = SCARD_E_TIMEOUT Then
Timer1.Enabled = True
Exit Sub
End If
Dim eventState As Long
eventState = readerState.dwEventState
lblStatus.Caption = eventState
If (eventState And SCARD_STATE_PRESENT) <> 0 Then
lblStatus.Caption = "カード挿入中"
'読込データ
Call ReadData
End If
If (eventState And SCARD_STATE_EMPTY) <> 0 Then
lblStatus.Caption = "カード未挿入"
Text1.Text = ""
End If
Timer1.Enabled = True
End Sub
'再接続
Private Sub cmdReStart_Click()
cmdReStart.Visible = False
Timer1.Enabled = True
End Sub
'データ読込処理
Private Sub ReadData()
Dim hCard As Long
Dim activeProtocol As Long
'カード通信処理
ret = SCardConnect(hContext, readerState.szReader, SCARD_SHARE_SHARED, SCARD_PROTOCOL_T1, hCard, activeProtocol)
If ret <> 0 Then
lblStatus.Caption = "エラー(Connect:" & Hex(ret) & ")"
Timer1.Enabled = True
Exit Sub
End If
Dim sendBuffer(4) As Byte
Dim recvBuffer(18) As Byte
Dim recvLen As Integer
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) = &HB0
sendBuffer(2) = &H0
sendBuffer(3) = &H4
sendBuffer(4) = CByte(16)
Call SendComand(hCard, ioSendReq, ioRecvReq)
'データ受信
recvLen = 18
ret = SCardTransmit(hCard, ioSendReq, sendBuffer(0), 5, ioRecvReq, recvBuffer(0), recvLen)
If ret <> 0 Then
lblStatus.Caption = "エラー(Transmit3:" & Hex(ret) & ")"
Exit Sub
End If
'データチェック
If recvBuffer(16) <> &H90 Then
lblStatus.Caption = "読込異常：" & Hex(recvBuffer(0)) & "," & Hex(recvBuffer(1))
Exit Sub
End If
'カード切断処理
ret = SCardDisconnect(hCard, SCARD_LEAVE_CARD)
If ret <> 0 Then
MsgBox ("Error5:" + Hex(ret))
Exit Sub
End If
'読込データセット
Dim cardData As String
cardData = ""
For i = 0 To 15
If Chr(recvBuffer(i)) <> Space(1) Then
cardData = cardData & Chr(recvBuffer(i))
End If
Next
Text1.Text = cardData
End Sub
'データ書き込み処理
Private Sub writeData()
Dim hCard As Long
Dim activeProtocol As Long
'カード通信処理
ret = SCardConnect(hContext, readerState.szReader, SCARD_SHARE_SHARED, SCARD_PROTOCOL_T1, hCard, activeProtocol)
If ret <> 0 Then
lblStatus.Caption = "エラー(Connect:" & Hex(ret) & ")"
Exit Sub
End If
Dim sendBuffer(22) As Byte
Dim writeData() As Byte
Dim recvBuffer(18) As Byte
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)
'書き込みデータ
writeData = StrConv(Text1.Text, vbFromUnicode)
'送信バッファ
sendBuffer(0) = &HFF
sendBuffer(1) = &HD6
sendBuffer(2) = &H0
sendBuffer(3) = &H4
sendBuffer(4) = 16
For i = 0 To UBound(writeData)
sendBuffer(5 + i) = writeData(i)
Next
Call SendComand(hCard, ioSendReq, ioRecvReq)
'データ受信
ret = SCardTransmit(hCard, ioSendReq, sendBuffer(0), UBound(sendBuffer), ioRecvReq, recvBuffer(0), UBound(recvBuffer))
If ret <> 0 Then
lblStatus.Caption = "エラー(Transmit3:" & Hex(ret) & ")"
Exit Sub
End If
'データチェック
If recvBuffer(0) <> &H90 Then
lblStatus.Caption = "書き込み異常：" & Hex(recvBuffer(0)) & "," & Hex(recvBuffer(1))
Exit Sub
End If
'カード切断処理
ret = SCardDisconnect(hCard, SCARD_LEAVE_CARD)
If ret <> 0 Then
MsgBox ("Error5:" + Hex(ret))
Exit Sub
End If
MsgBox ("書き込み完了")
End Sub
'コマンド送信処理
Private Sub SendComand(hCard As Long, ioSendReq As SCARD_IO_REQUEST, ioRecvReq As SCARD_IO_REQUEST)
Dim sendCommand1(10) As Byte
Dim sendCommand2(9) As Byte
Dim recvBuffer(2) As Byte
Dim recvLen As Integer
'送信コマンド（認証コマンド）
sendCommand1(0) = XXXX
・・・
sendCommand1(9) = XXXX
sendCommand2(0) = XXXX
・・・
sendCommand2(9) = XXXX
'認証ステータス送信
recvLen = 2
ret = SCardTransmit(hCard, ioSendReq, sendCommand1(0), 11, ioRecvReq, recvBuffer(0), recvLen)
If ret <> 0 Then
lblStatus.Caption = "エラー(Transmit1:" & Hex(ret) & ")"
Exit Sub
End If
ret = SCardTransmit(hCard, ioSendReq, sendCommand2(0), 10, ioRecvReq, recvBuffer(0), recvLen)
If ret <> 0 Then
lblStatus.Caption = "エラー(Transmit2:" & Hex(ret) & ")"
Exit Sub
End If
End Sub
--------------------------------------------------------------------------------
