First I use vba to read data from smart card, it is National ID . I just need id and name of the card . I work with chatGPT to generate code and edit it, till I struck at scardTransmit try to retrieve something in the card but it show error 1783 . could anyone give me some suggestion
here code
Declare PtrSafe Function SCardEstablishContext Lib "winscard.dll" (ByVal dwScope As Long, ByVal pvReserved1 As LongPtr, ByVal pvReserved2 As LongPtr, phContext As LongPtr) As Long
Declare PtrSafe Function SCardListReadersA Lib "winscard" (ByVal hContext As LongPtr, ByVal mszGroups As LongPtr, ByVal mszReaders As Any, ByRef pcchReaders As LongPtr) As Long
Declare PtrSafe Function SCardConnectW Lib "winscard" (ByVal hContext As LongPtr, ByVal szReader As LongPtr, ByVal dwShareMode As Long, ByVal dwPreferredProtocols As Long, ByRef phCard As LongPtr, ByRef pdwActiveProtocol As Long) As Long
Declare PtrSafe Function SCardStatusA Lib "winscard" (ByVal hCard As LongPtr, ByVal szReaderName As String, ByRef pcchReaderLen As LongPtr, pdwState As Long, pdwProtocol As Long, ByRef pbAtr As Byte, ByRef pcbAtrLen As LongPtr) As Long
Declare PtrSafe Function SCardTransmit Lib "winscard" (ByVal hCard As LongPtr, ByVal pioSendPci As LongPtr, ByVal pbSendBuffer As Byte, ByVal cbSendLength As Long, ByRef pioRecvPci As Any, ByRef pbRecvBuffer As Byte, ByRef pcbRecvLength As Long) As Long
Declare PtrSafe Function SCardDisconnect Lib "winscard" (ByVal hCard As LongPtr, ByVal dwDisposition As Long) As Long
Private Const SCARD_PROTOCOL_T0 As Long = &H1
Private Const SCARD_PROTOCOL_T1 As Long = &H2
Private Const SCARD_S_SUCCESS As Long = 0
Private Type SCARD_IO_REQUEST
dwProtocol As Long
cbPciLength As Long
End Type
Public Sub ConnectToSmartCard()
Dim sendPci As SCARD_IO_REQUEST
Dim recvPci As SCARD_IO_REQUEST
Dim hContext As LongPtr
Dim dwScope As LongPtr
Dim mszReaders As String * 1024
Dim pcchReaders As LongPtr
Dim szReader As String
Dim dwShareMode As Long
Dim dwPreferredProtocols As Long
Dim hCard As LongPtr
Dim dwActiveProtocol As Long
Dim pbAtr(36) As Byte ' Buffer to receive the ATR (maximum size is 36 bytes)
Dim pcbAtrLen As LongPtr ' Length of ATR buffer
Dim retCode As Long
Dim recvLength As Long
Dim sendBuffer() As Byte
Dim recvBuffer(2560000) As Byte
Dim hexString As String
dwScope = 2 'SCARD_SCOPE_SYSTEM
dwShareMode = 3 'SCARD_SHARE_SHARED
dwPreferredProtocols = 3 'SCARD_PROTOCOL_T0 or SCARD_PROTOCOL_T1
On Error GoTo ErrorHandler
' Establish context
retCode = SCardEstablishContext(dwScope, 0, 0, hContext)
If retCode <> 0 Then
MsgBox "Failed to establish context. Error code: " & retCode
Exit Sub
End If
' Get list of readers
pcchReaders = 1024
retCode = SCardListReadersA(hContext, 0, mszReaders, pcchReaders)
If retCode <> 0 Then
MsgBox "Failed to get list of readers. Error code: " & retCode
'SCardDisconnect hCard, 0 ' Disconnect if already connected
GoTo CleanUp
End If
' Get the first reader name (assuming only one reader)
szReader = Split(mszReaders, vbNullChar)(0)
' Connect to the card
retCode = SCardConnectW(hContext, StrPtr(szReader), dwShareMode, dwPreferredProtocols, hCard, dwActiveProtocol)
If retCode <> 0 Then
MsgBox "Failed to connect to the smart card. Error code: " & retCode
'SCardDisconnect hCard, 0 ' Disconnect if already connected
GoTo CleanUp
End If
' Get card status and retrieve ATR (Answer To Reset)
pcbAtrLen = UBound(pbAtr) + 1 ' Set the size of the buffer
retCode = SCardStatusA(hCard, vbNullString, 0, 0, 0, pbAtr(0), pcbAtrLen)
If retCode <> 0 Then
MsgBox "Failed to retrieve card status. Error code: " & retCode
GoTo CleanUp
Else
Dim atrHex As String
atrHex = ByteArrayToHexString(LeftB(pbAtr, pcbAtrLen))
' MsgBox "Connected to smart card in reader: " & szReader & vbCrLf & _
"ATR (Answer To Reset): " & atrHex
End If
'----------> pass till here i got atr which i try to compare with other program . so i got same ATR
sendPci.dwProtocol = SCARD_PROTOCOL_T0 ' or SCARD_PROTOCOL_T1
recvPci.dwProtocol = SCARD_PROTOCOL_T0 ' or SCARD_PROTOCOL_T1
sendPci.cbPciLength = LenB(sendPci)
recvPci.cbPciLength = LenB(recvPci)
hexString = "00A4040000" ' Example: SELECT EF command
sendBuffer = HexStringToByteArray(hexString)
recvLength = UBound(recvBuffer) + 1 ' Set the maximum size of the receive buffer
> error on this line with code 1783 , err description show error occur (0)
> retCode = SCardTransmit(hCard, VarPtr(sendPci), sendBuffer(0),
> UBound(sendBuffer) + 1, recvPci, recvBuffer(0), recvLength)
' Transmit the APDU command to the card
' retCode = SCardTransmit(hCard, 0, sendBuffer(0), UBound(sendBuffer) + 1, 0, recvBuffer(0), recvLength)
If retCode <> 0 Then
MsgBox "Failed to transmit APDU command to the card. Error code: " & retCode
GoTo CleanUp
End If
' Handle the response received from the card (recvBuffer) containing the queried data
MsgBox "pass send transmit"
CleanUp:
' Disconnect from the card
retCode = SCardDisconnect(hCard, 0)
If retCode <> 0 Then
MsgBox "Failed to disconnect from the smart card. Error code: " & retCode
End If
' Release the context
retCode = SCardEstablishContext(0, 0, 0, hContext)
If retCode <> 0 Then
MsgBox "Failed to release context. Error code: " & retCode
End If
ErrorHandler:
MsgBox "An error occurred: " & Err.Description & " (Error " & Err.Number & ")"
End Sub
Function HexStringToByteArray(hexString As String) As Byte()
Dim byteLength As Long
Dim byteArray() As Byte
Dim i As Long
byteLength = Len(hexString) \ 2
ReDim byteArray(0 To byteLength - 1)
For i = 0 To byteLength - 1
byteArray(i) = Val("&H" & Mid(hexString, i * 2 + 1, 2))
Next i
HexStringToByteArray = byteArray
End Function
thank you in advance.
after run command. I got error on SCardTransmit code 1783 which error on buffer (i think) I try to increase buffer but it isn't work. so I have no idea where should I fix it.
