Getting started with smartcard & ISO 7816 in excel vba ( SCardEstablishContext )

Question

I just received a standard cheap usb smartcard reader.

I'm trying to find out how to interact with it using VBA in excel.

-- I wrote this as I attempted to create basic smartcard functionality in a workbook. I figured at some point I would get stuck (and I did). If I get unstuck I will update this question until I reach my goal of working smartcard in excel.

TL;DR at this point the error is "Bad DLL calling convention" when calling function SCardListReaders

Smartcards are microcontrollers like AT88SC1608R powered by the reader.

There is a standard windows interface for dealing with the readers centered around winscard.dll.

Some of the documentation is here "Smart Card and Reader Access Functions"

After some research, it seems that the first thing to do is to receive a handle to a "resource manager context" using the function SCardEstablishContext.

This "context" object has "scopes", USER or SYSTEM. These are selected by the two constants SCARD_SCOPE_USER and SCARD_SCOPE_SYSTEM.

From this thread , it seems that SCARD_SCOPE_USER = 1 and SCARD_SCOPE_SYSTEM = 2 . I don't know if these values are signed. Also according to this page, the value of USER might be 0.

So, I have attempted to create some code to use SCardEstablishContext & SCardReleaseContext as follows.

Public Declare Function SCardEstablishContext Lib "winscard.dll" (ByVal dwScope As Long, _
                                                                    ByVal pvReserved1 As Long, _
                                                                    ByVal pvReserved2 As Long, _
                                                                    ByRef phContext As SCARDCONTEXT _
                                                                    ) As Long

Public Declare Function SCardReleaseContext Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT) As Long

Public Type SCARDCONTEXT
    CardContext1 As Long
    ReaderName As Byte
End Type

Sub GetContext()

    Dim lReturn As Long
    Dim RSVD1 As Long, RSVD2 As Long
    Dim myContext As SCARDCONTEXT

    ' Constants, maybe unsigned ?
    Dim SCARD_SCOPE_USER As Long
    Dim SCARD_SCOPE_SYSTEM As Long

    SCARD_SCOPE_USER = 1
    SCARD_SCOPE_SYSTEM = 2

    lReturn = SCardEstablishContext(SCARD_SCOPE_USER, RSVD1, RSVD2, myContext)

    Debug.Print lReturn
    Debug.Print myContext.CardContext1 & " " & myContext.ReaderName

    lReturn = SCardReleaseContext(myContext)
    Debug.Print lReturn

End Sub

Running this code returns

-2146435055 
0 0
 6

Using a decimal to hex converter I found that the hex value of this -2146435055 is FFFFFFFF80100011 and according to this chart Authentication Return Values

The first return value would be

SCARD_E_INVALID_VALUE
0x80100011
One or more of the supplied parameter values could not be properly interpreted.

I then tried using a value of 0 for SCARD_SCOPE_USER and got this more promising output

 0 
-855572480 0
 6

This might be working so moving on, the next function appears to be SCardConnect to establish a link to the card in the reader. A successful call here probably means the entire system is working.

I created the following declarations for SCardConnect

I found a list of the constants at this address

Public Const SCARD_SHARE_SHARED As Long = &H2
Public Const SCARD_SHARE_EXCLUSIVE As Long = &H1
Public Const SCARD_SHARE_DIRECT As Long = &H3
Public Const SCARD_PROTOCOL_T0 As Long = &H1
Public Const SCARD_PROTOCOL_T1 As Long = &H2
Public Declare Function SCardConnect Lib "winscard.dll" (ByVal phContext As SCARDCONTEXT, _
                                                                ByVal dwShareMode As Long, _
                                                                ByVal szReader As String, _
                                                                ByVal dwPreferredProtocols As Long, _
                                                                ByRef phCard As Long, _
                                                                ByRef pdwActiveProtocol As Long _
                                                                ) As Long

To call this function, I will need the name of the reader. It seems that the SCARDCONTEXT type was supposed to contain the name of the reader but my type declaration might be wrong, I only get an empty byte out of it. I tried changing the type of "ReaderName" variable to string, but then I just get an empty string.

So I will now attempt to use the SCardListReaders function to get the name.

This requires a new constant defined SCARD_DEFAULT_READERS containing text "SCard$DefaultReaders\000"

Public Const SCARD_DEFAULT_READERS As String = "SCard$DefaultReaders\000"

Public Declare Function SCardListReaders Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT, _
                                                                    ByVal dwShareMode As Long, _
                                                                    ByVal mszGroups As String, _
                                                                    ByRef mszReaders As String, _
                                                                    ByRef pcchReaders As Long _
                                                                    ) As Long

It appears that this function is to be used twice, first to get the length of the output string, by setting mszReaders to NULL the lenght will be outputted by pcchReaders. The second time we prepare a buffer to receive the string from mszReaders.

Now about to give this a try, here is the entire code as it exists.

Public Const SCARD_SCOPE_USER As Long = &H0
Public Const SCARD_SCOPE_SYSTEM As Long = &H2
Public Const SCARD_SHARE_SHARED As Long = &H2
Public Const SCARD_SHARE_EXCLUSIVE As Long = &H1
Public Const SCARD_SHARE_DIRECT As Long = &H3
Public Const SCARD_PROTOCOL_T0 As Long = &H1
Public Const SCARD_PROTOCOL_T1 As Long = &H2
Public Const SCARD_DEFAULT_READERS As String = "SCard$DefaultReaders\000"

Public Declare Function SCardEstablishContext Lib "winscard.dll" (ByVal dwScope As Long, _
                                                                    ByVal pvReserved1 As Long, _
                                                                    ByVal pvReserved2 As Long, _
                                                                    ByRef phContext As SCARDCONTEXT _
                                                                    ) As Long

Public Declare Function SCardReleaseContext Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT) As Long

Public Declare Function SCardConnect Lib "winscard.dll" (ByVal phContext As SCARDCONTEXT, _
                                                                    ByVal dwShareMode As Long, _
                                                                    ByVal szReader As String, _
                                                                    ByVal dwPreferredProtocols As Long, _
                                                                    ByRef phCard As Long, _
                                                                    ByRef pdwActiveProtocol As Long _
                                                                    ) As Long

Public Declare Function SCardListReaders Lib "winscard.dll" (ByRef phContext As SCARDCONTEXT, _
                                                                    ByVal dwShareMode As Long, _
                                                                    ByVal mszGroups As String, _
                                                                    ByRef mszReaders As String, _
                                                                    ByRef pcchReaders As Long _
                                                                    ) As Long

Public Type SCARDCONTEXT
    CardContext1 As Long
    ReaderName As String
End Type

Sub GetContext()

    Dim lReturn As Long
    Dim RSVD1 As Long, RSVD2 As Long
    Dim myContext As SCARDCONTEXT

    lReturn = SCardEstablishContext(SCARD_SCOPE_USER, RSVD1, RSVD2, myContext)

    Debug.Print "SCardEstablishContext: Return =" & lReturn & _
                " myContext.CardContext1 = " & myContext.CardContext1 & _
                " myContext.ReaderName = " & Chr(34) & myContext.ReaderName & Chr(34)

    Dim ListOfReaders As String, lenListOfReaders As Long

    lReturn = SCardListReaders(myContext, SCARD_SHARE_SHARED, SCARD_DEFAULT_READERS, ListOfReaders, lenListOfReaders)

    Debug.Print "SCardListReaders: Return =" & lReturn & _
                " ListOfReaders = " & Chr(34) & ListOfReaders & Chr(34) & _
                " lenListOfReaders = " & lenListOfReaders

    lReturn = SCardReleaseContext(myContext)
    Debug.Print "SCardReleaseContext: Return =" & lReturn

End Sub

I attempt to run and get the error

On line

lReturn = SCardListReaders(myContext, SCARD_SHARE_SHARED, SCARD_DEFAULT_READERS, ListOfReaders, lenListOfReaders)

Error

Run-time error '453':
Can't find DLL entry point SCardListReaders in winscard.dll

Reviewing the documentation for SCardListReaders function I find that it does list this DLL, winscard.dll for this function

There is also a line that says

Unicode and ANSI names
SCardListReadersW (Unicode) and SCardListReadersA (ANSI)

So I tried adding an "Alias" parameter to the declation for SCardListReaders and now the declaration is like this

Public Declare Function SCardListReaders Lib "winscard.dll" _
                                            Alias "SCardListReadersA" (ByRef phContext As SCARDCONTEXT, _
                                                                    ByVal dwShareMode As Long, _
                                                                    ByVal mszGroups As String, _
                                                                    ByRef mszReaders As String, _
                                                                    ByRef pcchReaders As Long _
                                                                    ) As Long

Running this code I get the error

Run-time error '49':
Bad DLL calling convention

According to VB documentation it seems that this error is often caused by " incorrectly omitting or including the ByVal keyword from the Declare statement".

Now I failed to mention something earlier, in the declaration for SCardListReaders, when I first tried it, I declared phContext as

ByVal phContext As SCARDCONTEXT

Since this is an input only, I figured it didn't need to be ByRef. However, when I did this I got the following error

Complile error:
User-defined type may not be passed ByVal

So I modified the line to be

ByRef phContext As SCARDCONTEXT

Which leads to the Bad DLL calling convention error.

To attempt to resolve this, I now replace all instances of

phContext As SCARDCONTEXT

with phContext As long

and give it another go

This gives the same "Bad DLL calling convention" error

So perhaps it really needed that SCARDCONTEXT type variable and looking at it again, I changed the type of ReaderName from Byte to String at some point

So I change the type declaration back to

Public Type SCARDCONTEXT
    CardContext1 As Long
    ReaderName As Byte
End Type

And I change back all phContext As long to phContext As SCARDCONTEXT and still I get the "Bad DLL calling convention" error !!

So I went back to the SCardEstablishContext function documentation for clues on the structure of that "LPSCARDCONTEXT phContext"

At this point I am stuck, I can't find how to properly declare this SCARDCONTEXT type or if that really is my error.

I hope you can find where I went wrong before and I also hope that this charts some of the road to working with smartcards in VBA for others.

thanks for reading, bye !

Why do you have 5 parameters for `SCardListReadersA`? Your linked documentation on MSDN only has 4. — Comintern, Sep 20 '16 at 12:35

score 1 · Answer 1 · answered Apr 27 '21 at 21:05

Here is some code that requests a user select a smartcard and returns the name of the card.

Option Explicit
Option Compare Database

Private Const CRYPTUI_SELECT_LOCATION_COLUMN = 16
Private Const CERT_NAME_SIMPLE_DISPLAY_TYPE = 4
Private Const CERT_NAME_FRIENDLY_DISPLAY_TYPE = 5
Private Const CERT_EKU_EMAIL = "1.3.6.1.5.5.7.3.4"
Private Const CERT_EKU_LOGON = "1.3.6.1.4.1.311.20.2.2"

Public Enum CERT_USAGE
    CERT_DATA_ENCIPHERMENT_KEY_USAGE = &H10
    CERT_DIGITAL_SIGNATURE_KEY_USAGE = &H80
    CERT_KEY_AGREEMENT_KEY_USAGE = &H8
    CERT_KEY_CERT_SIGN_KEY_USAGE = &H4
    CERT_KEY_ENCIPHERMENT_KEY_USAGE = &H20
    CERT_NON_REPUDIATION_KEY_USAGE = &H40
    CERT_OFFLINE_CRL_SIGN_KEY_USAGE = &H2
End Enum

Public Enum CERT_SELECT_MODE
    SHOW_NO_SELECTION = 0
    SHOW_ALL_ID_SELECT_LAST_LOGON = 1
    SHOW_ID = 2
    SHOW_LOGON = 3
    SHOW_ALL_SELECT_LAST_LOGON = 4
    SHOW_ALL = 5
    SHOW_ADLS_FRIENDLY = 6
End Enum

Private Type CERT_REVOCATION_STATUS
    cbSize As Long
    dwIndex As Long
    dwError As Long
    dwReason As Long
    fHasFreshnessTime As Boolean
    dwFreshnessTime As Long
End Type

Private Type FILE_TIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type

Private Type CRYPT_INTEGER_BLOB
    cbData As Long
    pbData As LongPtr
End Type

Private Type CRYPT_BIT_BLOB
    cbData As Long
    pbData() As Byte
    cUnusedBits As Long
End Type

Private Type CRYPT_ALGORITHM_IDENTIFIER
    pszObjId As LongPtr
    Parameters As CRYPT_INTEGER_BLOB
End Type

Private Type CERT_PUBLIC_KEY_INFO
    Algorithm As CRYPT_ALGORITHM_IDENTIFIER
    PublicKey As CRYPT_BIT_BLOB
End Type

Private Type CERT_INFO
    dwVersion As Long
    SerialNumber As CRYPT_INTEGER_BLOB
    SignatureAlgorithm As CRYPT_ALGORITHM_IDENTIFIER
    Issuer As CRYPT_INTEGER_BLOB
    NotBefore As Currency
    NotAfter As Currency
    Subject As CRYPT_INTEGER_BLOB
    SubjectPublicKeyInfo As CERT_PUBLIC_KEY_INFO
    IssuerUniqueId As CRYPT_BIT_BLOB
    SubjectUniqueId As CRYPT_BIT_BLOB
    cExtension As Long
    rgExtension As LongPtr
End Type

Private Type CRYPTUI_SELECTCERTIFICATE_STRUCTA
    dwSize As Long
    hWndParent As LongPtr ' OPTIONAL*/
    dwFlags As Long ' OPTIONAL*/
    szTitle As String ' OPTIONAL*/
    dwDontUseColumn As Long ' OPTIONAL*/
    szDisplayString As String ' OPTIONAL*/
    pFilterCallback As LongPtr ' OPTIONAL*/
    pDisplayCallback As LongPtr ' OPTIONAL*/
    pvCallbackData As LongPtr ' OPTIONAL*/
    cDisplayStores As Long
    rghDisplayStores As LongPtr
    cStores As Long ' OPTIONAL*/
    rghStores As LongPtr ' OPTIONAL*/
    cPropSheetPages As Long ' OPTIONAL*/
    rgPropSheetPages As LongPtr ' OPTIONAL*/
    hSelectedCertStore As LongPtr ' OPTIONAL*/
End Type

Public Type Cert_Context
    dwCertEncodingType As Long
    pbCertEncoded() As Byte
    cbCertEncoded As Long
    pCertInfo As LongPtr
    hCertStore As LongPtr
End Type

Private Declare PtrSafe Function CryptUIDlgSelectCertificateFromStore Lib _
    "Cryptui.dll" ( _
    ByVal hCertStore As LongPtr, _
    ByVal hWnd As LongPtr, _
    ByVal pwszTitle As String, _
    ByVal pwszDisplayString As String, _
    ByVal dwDontUseColumn As Long, _
    ByVal dwFlags As Long, _
    ByVal pvReserved As Any _
) As LongPtr

Private Declare PtrSafe Function CryptUIDlgSelectCertificate Lib _
    "Cryptui.dll" Alias "CryptUIDlgSelectCertificateW" ( _
    ByRef pcsc As CRYPTUI_SELECTCERTIFICATE_STRUCTA _
) As LongPtr

Private Declare PtrSafe Function CryptUIDlgSelectCertificate2 Lib _
    "Cryptui.dll" Alias "CryptUIDlgSelectCertificateW" ( _
    ByRef pcsc As CRYPTUI_SELECTCERTIFICATE_STRUCTA _
) As Cert_Context

Private Declare PtrSafe Function CertOpenSystemStore Lib _
    "crypt32.dll" Alias "CertOpenSystemStoreA" ( _
    ByVal hProv As LongPtr, _
    ByVal szSubsystemProtocol As String _
) As LongPtr

Private Declare PtrSafe Function CertEnumCertificatesInStore Lib _
    "crypt32.dll" ( _
    ByVal hCertStore As LongPtr, _
    ByVal pPrevCertContext As LongPtr _
) As LongPtr

Private Declare PtrSafe Function CertGetNameString Lib _
    "crypt32.dll" Alias "CertGetNameStringW" ( _
    ByVal pCertContext As LongPtr, _
    ByVal dwType As Long, _
    ByVal dwFlags As Long, _
    pvTypePara As Any, _
    ByVal pszNameString As LongPtr, _
    ByVal cchNameString As Long _
) As Long

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cbCopy As Long)

Private Function GetNameString(hCert_Context As LongPtr, Friendly As Boolean) As String
    Dim nPtr As LongPtr, bPtr As LongPtr
    Dim strNameString As String
    Dim szNameString As Long
    Dim nullBfr As String
    Dim constType As Long
    
    On Error GoTo erh
    
    If Friendly = True Then
        constType = CERT_NAME_FRIENDLY_DISPLAY_TYPE
    Else
        constType = CERT_NAME_SIMPLE_DISPLAY_TYPE
    End If

    nullBfr = String(1, vbNullChar)
    nPtr = StrPtr(nullBfr)
    szNameString = CertGetNameString(hCert_Context, _
        constType, _
        0&, _
        0, _
        nPtr, _
        0& _
        )
    
    If szNameString = 1 Then Err.Raise 4004, , "Certificate name contains no data."
    strNameString = String(szNameString, vbNullChar)
    bPtr = StrPtr(strNameString)
    szNameString = CertGetNameString(hCert_Context, _
        constType, _
        0&, _
        0&, _
        bPtr, _
        szNameString& _
        )
    GetNameString = Mid(strNameString, 1, szNameString - 1)
    strNameString = String(szNameString, vbNullChar)
Exit Function
erh:
Debug.Print "SCard::Error getting certificate name: " + _
Err.Description
End Function

Private Function GetCertificate(Optional bSelect As Boolean = False, _
    Optional bShowInfo As Boolean = False, _
    Optional CertMode As CERT_SELECT_MODE = SHOW_LOGON, _
    Optional ByRef CertStore As LongPtr, _
    Optional NoCache As Boolean = False, _
    Optional bSelectFirst As Boolean = False, _
    Optional CertSelectPrompt As String = "") _
    As LongPtr

    Dim hCert_Context As LongPtr
    Dim rghSystemStore As LongPtr
    Dim pszStoreName As String
    Dim pcsc As CRYPTUI_SELECTCERTIFICATE_STRUCTA
    Dim CertType As String, CertUsage As CERT_USAGE
    Dim PFNCOption As Long
    Dim CertCheckEKU As Boolean
    Dim strPrompt As String
    On Error GoTo erh

Select Case CertMode
    Case CERT_SELECT_MODE.SHOW_ALL_ID_SELECT_LAST_LOGON
        '///OPTION 1: SHOW ALL ID CERTS AND SELECT LAST LOGON CERT
        CertType = CERT_EKU_LOGON
        CertCheckEKU = True
        PFNCOption = 1
    Case CERT_SELECT_MODE.SHOW_ID '///OPTION 2: SHOW JUST ID CERTS
        CertType = CERT_EKU_EMAIL
        CertCheckEKU = True
        PFNCOption = 2
    Case CERT_SELECT_MODE.SHOW_LOGON '///OPTION 3: SHOW ONLY LOGON CERTS
        CertType = CERT_EKU_LOGON
        CertCheckEKU = True
        PFNCOption = 3
    Case CERT_SELECT_MODE.SHOW_ALL_SELECT_LAST_LOGON
        '///OPTION 4: SHOW ALL CERTS, SELECT LAST LOGON CERT
        bSelect = True
        CertType = CERT_EKU_LOGON
        CertCheckEKU = True
        PFNCOption = 4
    Case CERT_SELECT_MODE.SHOW_ALL '///OPTION 5: SHOW ALL CERTS
        bSelect = True
        PFNCOption = 5
    Case CERT_SELECT_MODE.SHOW_ADLS_FRIENDLY
        '///OPTION 5: SHOW CERTS with digital signature
        ' and no secure email EKU
        bSelect = False
        CertUsage = CERT_DIGITAL_SIGNATURE_KEY_USAGE
        CertCheckEKU = False
        PFNCOption = 6
End Select

If CertSelectPrompt = "" Then
    strPrompt = "Select a certificate."
Else
    strPrompt = CertSelectPrompt
End If

'open the personal certificate store
pszStoreName = "MY"
rghSystemStore = CertOpenSystemStore(0&, pszStoreName)
If rghSystemStore = 0 Then Err.Raise 4001, , "Failed to open the certificate store."
CertStore = rghSystemStore
hCert_Context = 0

If GETTEMP("CACHED_CERT") <> "" And NoCache = False Then
    Do
        hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
        hCert_Context)
        If GetSerialNumberAndHash(hCert_Context) = _
            GETTEMP("CACHED_CERT") Then
            GetCertificate = hCert_Context
            Exit Function
        End If
    Loop Until hCert_Context = 0&
End If

'///OPTIONS FOR CERTIFICATE SELECTION:
'////OPTION 1: SHOW SELECTION DIALOG OF LOGON CERTIFICATES
If bSelect Then
select_cert:
    pcsc.dwSize = LenB(pcsc)
    pcsc.rghDisplayStores = VarPtr(rghSystemStore)
    pcsc.cDisplayStores = 1
    pcsc.szTitle = StrConv("Please select a certificate:", vbUnicode)
    pcsc.szDisplayString = StrConv("", vbUnicode)
    pcsc.dwDontUseColumn = CRYPTUI_SELECT_LOCATION_COLUMN
    pcsc.pFilterCallback = GetCallBack(AddressOf PFNCFILTERPROC)
    pcsc.pvCallbackData = VarPtr(PFNCOption)
    pcsc.dwFlags = 0&
    pcsc.hWndParent = Application.hWndAccessApp
    hCert_Context = CryptUIDlgSelectCertificate(pcsc)
Else
'////OPTION 2:SELECT LOGON CERTIFICATE IN STORE BY DEFAULT
    If bSelectFirst Then
        Do
            hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
            hCert_Context)
            If CertCheckEKU Then
                If GetCertificateEKU(hCert_Context, CertType) Then Exit Do
            Else
                If GetCertificateUsage2(hCert_Context, CertUsage) Then Exit Do
            End If
        Loop Until hCert_Context = 0&

    ElseIf (CertCheckEKU And (CountOfCertificatesByEKU(CertType) <> 1)) And Not bSelectFirst Then
        GoTo select_cert
    ElseIf (Not CertCheckEKU And (CountOfCertificatesByUsage(CertUsage) <> 1)) And Not bSelectFirst Then
        GoTo select_cert
    End If
End If

If hCert_Context = 0& Then Err.Raise 4002, , _
    "Failed to acquire a valid certificate context or the " + _
    "user pressed cancel."
'///END OPTIONS
GetCertificate = hCert_Context
Exit Function
erh:
Debug.Print "DB_SCard::Error while getting certificate: " + _
Err.Description
GetCertificate = 0
End Function

Private Function GetSerialNumberAndHash(hContext As LongPtr) As String
    On Error GoTo erh
    GetSerialNumberAndHash = StrConv(CertGetProperty(hContext, CERT_ISSUER_SERIAL_NUMBER_MD5_HASH_PROP_ID), vbUnicode)
    Exit Function
erh:
    Debug.Print _
    "DB_SCard::Error while retrieving serial number and hash: " + _
    Err.Description
End Function

Private Function GetCallBack(funcAddr As LongPtr) As LongPtr
    GetCallBack = funcAddr
End Function

Private Function GetCertificateUsage2(ByRef cContext As LongPtr, Usage As CERT_USAGE) As Boolean
    Dim pbKeyUsage As LongPtr
    Dim oBfr As Long
    Dim rtn As Boolean
    Dim bBfr(0 To 7) As Boolean
    Dim GLE As Long
    Dim certcontext As Cert_Context
    Dim certinfo As CERT_INFO

    On Error Resume Next
    
    If cContext <> 0 Then
        CopyMemory VarPtr(certcontext), cContext, LenB(certcontext)
    End If
    
    If certcontext.pCertInfo <> 0 Then
        CopyMemory VarPtr(certinfo), certcontext.pCertInfo, LenB(certinfo)
    End If

    pbKeyUsage = VarPtr(oBfr)
    rtn = CertGetIntendedKeyUsage(X509_ASN_ENCODING, _
        VarPtr(certinfo), _
        pbKeyUsage, _
        4& _
        )
    GLE = Err.LastDllError
    
    If rtn Then
        BitBreak oBfr, bBfr
        If bBfr(Log2(Usage)) = True Then GetCertificateUsage2 = True
    ElseIf oBfr = 0 Then
        GetCertificateUsage2 = False
    Else
        Debug.Print _
        "DB_SCard::Error getting certificate usage: " + GLEtx(GLE)
    End If
End Function

Private Function GetCertificateEKU(ByVal pContext As LongPtr, eUsage As String) As Boolean
    Dim oBfr As CERT_ENHKEY_USAGE
    Dim oBfrsz As Long
    Dim rtn As Boolean
    Dim iter1 As Long
    Dim nArray() As Variant
    Dim GLE As Long

    On Error Resume Next

    If pContext = 0 Then Exit Function

    oBfrsz = Len(oBfr)
    rtn = CertGetEnhancedKeyUsage(pContext, 0&, VarPtr(oBfr), VarPtr(oBfrsz))
    GLE = Err.LastDllError

    If rtn Then

        If oBfr.cUsageIdentifier = 0 Then
            GetCertificateEKU = False
        Else
            nStrToArray StrConv(oBfr.rgpszUsageIdentifier, vbUnicode), nArray
            For iter1 = 1 To UBound(nArray)
                If eUsage = nArray(iter1) Then If VerifyRevocation(pContext) Then GetCertificateEKU = True
            Next iter1
        End If

    Else
        Debug.Print _
        "DB_SCard::Error getting enhanced certificate usage: " + GLEtx(GLE)
    End If
End Function

Public Function PFNCFILTERPROC( _
    ByRef pCertContext As Cert_Context, _
    ByVal pfInitialSelectedCert As Long, _
    ByVal pvCallbackData As LongPtr _
    ) As Long
    Dim certName As String
    
    
    certName = GetNameString(VarPtr(pCertContext), True)
    
    If Right(certName, 10) = Left(Environ("username"), 10) Then
        PFNCFILTERPROC = 1
    Else
        PFNCFILTERPROC = 0
    End If
End Function

Private Function CountOfCertificatesByEKU(ByVal Usage As String) As Long
    Dim hCert_Context As LongPtr
    Dim rghSystemStore As LongPtr
    Dim pszStoreName As String
    Dim CT As Long
    
    On Error GoTo erh

    pszStoreName = "MY"
    rghSystemStore = CertOpenSystemStore(0&, pszStoreName)
    
    If rghSystemStore = 0 Then Err.Raise 4001, , "Failed to open the certificate store."
    hCert_Context = 0
    CT = 0

    Do Until hCert_Context = 0
        hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
        hCert_Context)
        If GetCertificateEKU(hCert_Context, Usage) Then CT = CT + 1
    Loop

    Debug.Print "DB_SCard::Count of certificates matching EKU " + Usage; ": "  '+ cstr(CT)
    CountOfCertificatesByEKU = CT
    
out:
    CertFreeCertificateContext hCert_Context
    CertCloseStore rghSystemStore, 0&
    Exit Function
erh:
    Debug.Print _
    "DB_SCard::Error while enumerating certificates by EKU: " + _
    Err.Description
    GoTo out
End Function

Private Function CountOfCertificatesByUsage(ByVal Usage As CERT_USAGE) As Long
    Dim hCert_Context As LongPtr
    Dim rghSystemStore As LongPtr
    Dim pszStoreName As String
    Dim CT As Long
        
    On Error GoTo erh
    
    pszStoreName = "MY"
    rghSystemStore = CertOpenSystemStore(0&, pszStoreName)
    
    If rghSystemStore = 0 Then Err.Raise 4001, , "Failed to open the certificate store."
    hCert_Context = 0
    CT = 0
    
    Do Until hCert_Context = 0
        hCert_Context = CertEnumCertificatesInStore(rghSystemStore, _
        hCert_Context)
        If GetCertificateUsage2(hCert_Context, Usage) Then CT = CT + 1
    Loop

    CountOfCertificatesByUsage = CT
out:
    CertFreeCertificateContext hCert_Context
    CertCloseStore rghSystemStore, 0&
    Exit Function
erh:
    Debug.Print _
    "DB_SCard::Error while enumerating certificates by usage: " + Err.Description
    GoTo out
End Function

Public Function GetLongFromPointer(ByVal lPointer As LongPtr) As Long
    On Error Resume Next
    Dim outLng As Long
    If lPointer > 0 Then CopyMemory VarPtr(outLng), lPointer, 4
    GetLongFromPointer = outLng
End Function

Public Function GetCertFromContext(ByVal hCert_Context As LongPtr) As Cert_Context
    On Error Resume Next
    Dim pcc As Cert_Context
    CopyMemory VarPtr(pcc), hCert_Context, LenB(pcc)
    GetCertFromContext = pcc
End Function

Private Function GETTEMP(ByVal testIt As String) As String
    GETTEMP = ""
End Function

Private Function GLEtx(GLE) As String
    GLEtx = CStr(GLEtx)
End Function

Public Function testCert() As LongPtr
    Dim rghSystemStore As LongPtr, pszStoreName As String, CertStore As LongPtr, hCert_Context As LongPtr, emptyS As LongPtr
    pszStoreName = "MY"
    rghSystemStore = CertOpenSystemStore(emptyS, pszStoreName)
    testCert = GetCertificate(True, False, 3, rghSystemStore, True, False, "Please choose a certificate to use")
End Function

Public Function testFuncs() As String
    Dim blargh As Long
    blargh = testCert
    testFuncs = GetNameString(blargh, True)
End Function

Hello, the line Option Compare Database returns syntax error "compile error: expected text or binary" I have commented out this line and print testfuncts, a message appears on the immediate windows, however all of excel immediately crashes ! I managed to screengrab this error before excel disappeared "DB_Scard::Error while getting certificate: Object doesn't support this property or method". This was executed with no card within the card reader's EM field. — Shodan, Oct 07 '21 at 21:34
I tried the same with my debit card, credit card, employee badge. I placed them within my RFIDeas WAVE ID pcProx Writer 's EM field until the led turned green and then I ran the print testfuncs command, it spit out the same error message and crashed to desktop — Shodan, Oct 07 '21 at 21:36

Getting started with smartcard & ISO 7816 in excel vba ( SCardEstablishContext )

1 Answers1

Linked