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

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 !

Answer 1

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