在 excel vba ( SCardEstablishContext ) 中开始使用智能卡和 ISO 7816

Question

我刚刚收到了一个标准便宜的usb smartcard reader。

我正在尝试找出如何在 Excel 中使用 VBA 与之交互。

-- 我在尝试在工作簿中创建基本的智能卡功能时写了这个。我想在某些时候我会卡住（我确实卡住了）。如果我遇到困难，我会更新这个问题，直到我达到在 excel 中使用智能卡的目标。

TL;DR此时调用函数SCardListReaders时的错误是“错误的DLL调用约定”

智能卡是由读卡器供电的微控制器，例如 AT88SC1608R。

有一个标准的windows界面来处理以winscard.dll为中心的阅读器。

一些文档在这里“Smart Card and Reader Access Functions”

经过一番研究，似乎要做的第一件事是使用函数SCardEstablishContext 接收“resource manager context”的句柄。

此“上下文”对象具有“范围”，即 USER 或 SYSTEM。这些由两个常量 SCARD_SCOPE_USER 和 SCARD_SCOPE_SYSTEM 选择。

从this thread 看来， SCARD_SCOPE_USER = 1 和 SCARD_SCOPE_SYSTEM = 2 。我不知道这些值是否已签名。同样根据this page，USER的值可能是0。

所以，我尝试创建一些代码来使用 SCardEstablishContext 和 SCardReleaseContext，如下所示。

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

运行此代码返回

-2146435055 
0 0
 6 

使用十进制到十六进制转换器我发现这个 -2146435055 的十六进制值是 FFFFFFFF80100011 并且根据这张图表Authentication Return Values

第一个返回值是

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

然后我尝试为 SCARD_SCOPE_USER 使用 0 值并得到了这个更有希望的输出

 0 
-855572480 0
 6 

这可能会继续工作，下一个功能似乎是 SCardConnect，用于在读卡器中建立到卡的链接。这里调用成功可能意味着整个系统都在工作。

我为 SCardConnect 创建了以下声明

我在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

要调用这个函数，我需要读者的名字。似乎 SCARDCONTEXT 类型应该包含阅读器的名称，但我的类型声明可能是错误的，我只能从中得到一个空字节。我尝试将“ReaderName”变量的类型更改为字符串，但后来我得到一个空字符串。

所以我现在将尝试使用 SCardListReaders 函数来获取名称。

这需要一个新的常量定义 SCARD_DEFAULT_READERS 包含文本“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

看来这个函数要使用两次，第一次是获取输出字符串的长度，通过将 mszReaders 设置为 NULL 长度将由 pcchReaders 输出。第二次我们准备一个缓冲区来接收来自 mszReaders 的字符串。

现在要试一试，这里是完整的代码。

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

我尝试运行并得到错误

上线

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

错误

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

查看SCardListReaders function 的文档我发现它确实列出了这个DLL，winscard.dll 用于这个函数

还有一行写着

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

所以我尝试在 SCardListReaders 的声明中添加“别名”参数，现在声明是这样的

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

运行这段代码我得到了错误

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

根据VB documentation 看来，此错误通常是由“在 Declare 语句中错误地省略或包含 ByVal 关键字”引起的。

现在我之前没有提到一些东西，在 SCardListReaders 的声明中，当我第一次尝试它时，我将 phContext 声明为

ByVal phContext As SCARDCONTEXT

由于这只是一个输入，我认为它不需要是 ByRef。 但是，当我这样做时，出现以下错误

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

所以我将这一行修改为

ByRef phContext As SCARDCONTEXT

这会导致 Bad DLL 调用约定错误。

为了尝试解决这个问题，我现在替换

的所有实例

phContext As SCARDCONTEXT

与 phContext 只要

再试一次

这给出了相同的“错误的 DLL 调用约定”错误

所以也许它真的需要 SCARDCONTEXT 类型变量并再次查看它，我在某个时候将 ReaderName 的类型从 Byte 更改为 String

所以我把类型声明改回

Public Type SCARDCONTEXT
    CardContext1 As Long
    ReaderName As Byte
End Type

我将所有 phContext 只要改回 phContext As SCARDCONTEXT ，但我仍然收到“Bad DLL calling convention”错误！！

所以我回到了SCardEstablishContext function 文档，以获取有关“LPSCARDCONTEXT phContext”结构的线索

此时我被卡住了，我找不到如何正确声明此 SCARDCONTEXT 类型，或者这确实是我的错误。

我希望你能找到我以前出错的地方，我也希望这能为其他人在 VBA 中使用智能卡绘制一些道路。

感谢阅读，再见！

Answer 1

这是一些要求用户选择智能卡并返回卡名称的代码。

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