Lettura Tessera Sanitaria con VBA Access

di il
2 risposte

Lettura Tessera Sanitaria con VBA Access

Salve a tutti.
Premetto che ho poca esperienza di programmazione, ma con tutto ciò non mi tiro mai indietro davanti alle difficoltà.
Da qualche tempo mi sono imbattuto nella lettura della mia tessera sanitaria, e dopo parecchie righe di codice con scarso risultato volevo fare un consulto nel forum per capire dove sto sbagliando. Ringrazio chiunque potesse aiutarmi e di seguito posto il codice :



Public Type SCARD_IO_REQUEST
dwProtocol As Long
dbPciLength As Long
End Type

Public Type APDURec
bCLA As Byte
bINS As Byte
bP1 As Byte
bP2 As Byte
bP3 As Byte
DATA(1 To 255) As Byte
DataIn(1 To 255) As Byte
DataOut(1 To 255) As Byte
SW(1 To 2) As Byte
IsSend As Boolean
End Type

Public Type SCARD_READERSTATE
RdrName As String
UserData As Long
RdrCurrState As Long
RdrEventState As Long
ATRLength As Long
ATRValue(1 To 36) As Byte
End Type

Public Declare Function SCardEstablishContext Lib "winscard.dll" (ByVal dwScope As Long, _
ByVal pvReserved1 As Long, _
ByVal pvReserved2 As Long, _
ByRef hContext 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, _
ByRef pioRecvRequest As SCARD_IO_REQUEST, _
ByRef recvbuff As Byte, _
ByRef RecvBuffLen As Long) As Long


Public Declare Function SCardTransmitLong Lib "winscard.dll" Alias "SCardTransmit" (ByVal hCard As Long, _
ByRef pioSendPci As SCARD_IO_REQUEST, _
ByRef pbSendBuffer As Byte, _
ByVal cbSendLength As Long, _
ByVal pioRecvPci As Long, _
ByRef pbRecvBuffer As Byte, _
ByRef pcbRecvLength 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 Function SCardGetStatusChange Lib "winscard.dll" Alias "SCardGetStatusChangeA" (ByVal hContext As Long, _
ByVal TimeOut As Long, _
ByRef ReaderState As SCARD_READERSTATE, _
ByVal ReaderCount As Long) As Long

Public Declare Function SCardControl Lib "winscard.dll" (ByVal hCard As Long, _
ByVal dwControlCode As Long, _
ByRef pvInBuffer As Byte, _
ByVal cbInBufferSize As Long, _
ByRef pvOutBuffer As Byte, _
ByVal cbOutBufferSize As Long, _
ByRef pcbBytesReturned As Long) As Long


Public Type SCARDCONTEXT
CardContextl As Long
ReaderName As Byte
End Type


Sub Leggi()

Dim hContext As Long
Dim hCard As Long
Dim retval As Long
Dim readers As String * 256
Dim groups As String * 256
Dim pcchReaders As Long
Dim activeprotocol As Long
Dim readerlen As Long
Dim szReaderName As String
Dim SW1 As Long, SW2 As Long

Dim scard_protocol_t0_or_t1 As Long
Dim SCARD_SHARE_SHARED As Long
Dim SCARD_SCOPE_USER As Long
Dim SCARD_SCOPE_SYSTEM As Long

SCARD_SHARE_SHARED = 3
SCARD_SCOPE_USER = 1
SCARD_SCOPE_SYSTEM = 2

retval = SCardEstablishContext(SCARD_SCOPE_SYSTEM, SW1, SW2, hContext)
If (retval <> 0) Then MsgBox ("Errore: " & CStr(retval))

readerlen = 256

Dim recvlel As Long
Dim strHexa As String
scard_protocol_t0_or_t1 = 0
SCARD_SHARE_SHARED = 3
strHexa = ""

' FACCIO UNA LISTA DEI LETTORI DISPONIBILI
retval = SCardListReaders(hContext, groups, readers, readerlen)
If retval <> 0 Then
MsgBox "errore SCardListReaders n. " & CStr(retval)

Exit Sub
End If


' ######################################################################
' APRO LA CONNESSIONE CON LA CARTA
retval = SCardConnect(hContext, readers, SCARD_SHARE_SHARED, scard_protocol_t0_or_t1, hCard, activeprotocol)

If (retval <> 0) Then
MsgBox ("Tessera non inserita. Errore: " & CStr(retval))
Exit Sub
End If
' ######################################################################

retval = SCardDisconnect(hCard, 0)
If (retval <> 0) Then MsgBox ("Errore: " & CStr(retval))

retval = SCardReleaseContext(hContext)
If (retval <> 0) Then MsgBox ("Errore: " & CStr(retval))


Dim apdu(261) As Byte
Dim recvbuff(258) As Byte
Dim recvlen As Integer
Dim RecvBuffLen As Long
Dim pioSendRequest As SCARD_IO_REQUEST
Dim pioRecvRequest As SCARD_IO_REQUEST

' STRINGA APDU
apdu(0) = &H0 'CLA
apdu(1) = &HCA 'INS
apdu(2) = &H0 'P1
apdu(3) = &H81 'P2
apdu(4) = &H0 'LC
apdu(5) = &H0 'LE

recvlen = 257

pioSendRequest.dwProtocol = activeprotocol
pioSendRequest.dbPciLength = Len(pioSendRequest)
pioRecvRequest.dwProtocol = activeprotocol
pioRecvRequest.dbPciLength = Len(pioSendRequest)

retval = SCardTransmit(hCard, pioSendRequest, apdu(0), 6, pioRecvRequest, recvbuff(0), RecvBuffLen)
If (retval <> 0) Then MsgBox ("Errore nella trasmissione: " & CStr(retval))

'---------------------
' LIVELLO MF
'---------------------
apdu(0) = &H0 'CLA
apdu(1) = &HA4 'INS
apdu(2) = &H9 'P1
apdu(3) = &H0 'P2
apdu(4) = &H2 'LC
apdu(5) = &H3F
apdu(6) = &H0

recvlen = 257

pioSendRequest.dwProtocol = activeprotocol
pioSendRequest.dbPciLength = Len(pioSendRequest)
pioRecvRequest.dwProtocol = activeprotocol
pioRecvRequest.dbPciLength = Len(pioSendRequest)

retval = SCardTransmit(hCard, pioSendRequest, apdu(0), 7, pioRecvRequest, recvbuff(0), RecvBuffLen)
If (retval <> 0) Then
MsgBox ("Errore n." & CStr(retval))
End If

'---------------------
' LIVELLO EF 1100
'---------------------

apdu(0) = &H0 'CLA
apdu(1) = &HA4 'INS
apdu(2) = &H9 'P1
apdu(3) = &H0 'P2
apdu(4) = &H2 'LC
apdu(5) = &H11
apdu(6) = &H0

recvlen = 257

pioSendRequest.dwProtocol = activeprotocol
pioSendRequest.dbPciLength = Len(pioSendRequest)
pioRecvRequest.dwProtocol = activeprotocol
pioRecvRequest.dbPciLength = Len(pioSendRequest)

retval = SCardTransmit(hCard, pioSendRequest, apdu(0), 7, pioRecvRequest, recvbuff(0), RecvBuffLen)
If (retval <> 0) Then
MsgBox ("Errore n." & CStr(retval))
End If

'---------------------
' LIVELLO EF 1102 - DATI PERSONALI CONTENUTI NELLA CARTA
'---------------------

apdu(0) = &H0 'CLA
apdu(1) = &HA4 'INS
apdu(2) = &H9 'P1
apdu(3) = &H0 'P2
apdu(4) = &H2 'LC
apdu(5) = &H11
apdu(6) = &H2

recvlen = 257

pioSendRequest.dwProtocol = activeprotocol
pioSendRequest.dbPciLength = Len(pioSendRequest)
pioRecvRequest.dwProtocol = activeprotocol
pioRecvRequest.dbPciLength = Len(pioSendRequest)

retval = SCardTransmit(hCard, pioSendRequest, apdu(0), 7, pioRecvRequest, recvbuff(0), RecvBuffLen)
If (retval <> 0) Then
MsgBox ("Errore n." & CStr(retval))
End If

' LEGGO I BINARY PROVENIENTI DALLA CARTA
apdu(0) = &H0 'CLA
apdu(1) = &HB0 'INS
apdu(2) = &H0 'P1
apdu(3) = &H0 'P2
apdu(4) = &H96 'LC

recvlen = 257

pioSendRequest.dwProtocol = activeprotocol
pioSendRequest.dbPciLength = Len(pioSendRequest)
pioRecvRequest.dwProtocol = activeprotocol
pioRecvRequest.dbPciLength = Len(pioSendRequest)

retval = SCardTransmit(hCard, pioSendRequest, apdu(0), 5, pioRecvRequest, recvbuff(0), RecvBuffLen)
If (retval <> 0) Then
MsgBox ("Errore n." & CStr(retval))
End If

Dim risposta As String
risposta = ""

Dim k, LenEmettitore, LenRilascio, LenScadenza, LenCognome, LenNome, LenValore1, LenValore2, LenValore3, LenCodice As Long
Dim Emettitore, Rilascio, Scadenza, Nome, Cognome, CODICE As String

For k = 0 To apdu(4) - 1: risposta = risposta + Chr(recvbuff(k)): Next k

' ESTRAGGO COGNOME, NOME, CODICE FISCALE
' IN BASE ALLA POSIZIONE NELLA STRINGA DI RISPOSTA DALLA CARTA

Dim PosIni
PosIni = 1

risposta = Trim(risposta)
risposta = Mid(risposta, 7)
LenEmettitore = HexToLong(Int(Mid(risposta, PosIni, 2)))
PosIni = PosIni + 2
Emettitore = Mid(risposta, PosIni, LenEmettitore)

PosIni = PosIni + LenEmettitore
LenRilascio = Int(Mid(risposta, PosIni, 2))
PosIni = PosIni + 2
Rilascio = Mid(risposta, PosIni, LenRilascio)

PosIni = PosIni + LenRilascio
LenScadenza = Int(Mid(risposta, PosIni, 2))
PosIni = PosIni + 2
Scadenza = Mid(risposta, PosIni, LenScadenza)

PosIni = PosIni + LenScadenza
LenCognome = Int(Mid(risposta, PosIni, 2))
PosIni = PosIni + 2
Cognome = Mid(risposta, PosIni, LenCognome)
' txtDati.Text = Cognome
MsgBox ("Cognome: " & CStr(Cognome))

PosIni = PosIni + LenCognome
LenNome = Int(Mid(risposta, PosIni, 2))
PosIni = PosIni + 2
Nome = Mid(risposta, PosIni, LenNome)
' txtDati.Text = txtDati.Text & " - " & Nome

PosIni = PosIni + LenNome
LenValore1 = Int(Mid(risposta, PosIni, 2))
PosIni = PosIni + 2
PosIni = PosIni + LenValore1
LenValore2 = Int(Mid(risposta, PosIni, 2))
PosIni = PosIni + 2
PosIni = PosIni + LenValore2
LenValore3 = Int(Mid(risposta, PosIni, 2))
PosIni = PosIni + 2
PosIni = PosIni + LenValore3

LenCodice = HexToLong(Int(Mid(risposta, PosIni, 2)))
PosIni = PosIni + 2
CODICE = Mid(risposta, PosIni, LenCodice)
' txtDati.Text = txtDati.Text & " - " & CODICE

' ############################################################################
' CHIUDO LA CONNESSIONE CON LA CARTA

retval = SCardDisconnect(hCard, 0)
If (retval <> 0) Then MsgBox ("Errore: " & CStr(retval))

retval = SCardReleaseContext(hContext)
If (retval <> 0) Then MsgBox ("Errore: " & CStr(retval))


' ############################################################################
End Sub


Function HexToLong(ByVal sValue As String) As Long

If UCase(Left(sValue, 2)) <> "&H" Then
sValue = "&H" & sValue
End If

If Right(sValue, 1) <> "&" Then
sValue = sValue & "&"
End If

HexToLong = Val(sValue)

End Function

2 Risposte

  • Re: Lettura Tessera Sanitaria con VBA Access

    Scusa ma hai pubblicato 200 righe di codice, che ovviamente hai copiato, ma non dici assolutamente nulla.
    Cosa non funziona...?
    Che versione di Access hai...? (32 o 64 bit)
    Che prove hai fatto...?
    Sai fare debug...?
    Conosci come lavorano le API ...?
    La dichiarazione con Ptrsafe per le versioni recenti e le varie modifiche al 64bit..?

    Insomma cosa pensi che si prenda il tuo codice e lo si testi per trovarti il problema....?
    Sbagliato...!!!!
  • Re: Lettura Tessera Sanitaria con VBA Access

    Pace a voi,
    Spero di non fare necroposting.

    Dopo aver fatto le dovute modifiche al codice per passare da 32 a 64 bit
    dopo aver riscritto alcune variabili dal vecchio vb6 a vba
    dopo aver creato i file moduli, dove la maggior parte delle dichiarazioni dovevano essere poste.

    Non ho trovato alcun errore nel codice, mi funziona perfettamente.

    Ergo mi sa che copia-incolla senza sapere cosa si sta facendo è deleterio per chi lo fa e chi lo dovrebbe poi controllare.

    Comunque il no reply da Gennaio spiega molte cose.

    Consiglierei di utilizzare delle librerie più recenti, tipo python, molto più semplice da gestire.
    Basta che cerchi "WINSCARD.DLL librerie python" al massimo in c dal sito di MammaMicrosoft.
Devi accedere o registrarti per scrivere nel forum
2 risposte