Certificate.NET.vba

Option Explicit

' Windows API Declarations
Private Declare PtrSafe Function CertOpenSystemStore Lib "crypt32.dll" Alias "CertOpenSystemStoreA" (ByVal hProv As LongPtr, ByVal szSubsystemProtocol As String) As LongPtr
Private Declare PtrSafe Function CertFindCertificateInStore Lib "crypt32.dll" (ByVal hCertStore As LongPtr, ByVal dwCertEncodingType As Long, ByVal dwFindFlags As Long, ByVal dwFindType As Long, ByVal pvFindPara As LongPtr, ByVal pPrevCertContext As LongPtr) As LongPtr
Private Declare PtrSafe Function CertGetNameString Lib "crypt32.dll" Alias "CertGetNameStringA" (ByVal pCertContext As LongPtr, ByVal dwType As Long, ByVal dwFlags As Long, ByVal pvTypePara As LongPtr, ByVal pszNameString As String, ByVal cchNameString As Long) As Long
Private Declare PtrSafe Function CertGetCertificateContextProperty Lib "crypt32.dll" (ByVal pCertContext As LongPtr, ByVal dwPropId As Long, ByVal pvData As LongPtr, ByRef pcbData As Long) As Long
Private Declare PtrSafe Function CertCloseStore Lib "crypt32.dll" (ByVal hCertStore As LongPtr, ByVal dwFlags As Long) As Long

' Constants for the API
Private Const CERT_STORE_PROV_SYSTEM As Long = 10
Private Const CERT_STORE_OPEN_EXISTING_FLAG As Long = &H4000
Private Const CERT_STORE_READONLY_FLAG As Long = &H8000
Private Const X509_ASN_ENCODING As Long = &H1
Private Const CERT_FIND_ANY As Long = 0
Private Const CERT_NAME_SIMPLE_DISPLAY_TYPE As Long = 4
Private Const CERT_KEY_PROV_INFO_PROP_ID As Long = 2
Private Const CERT_KEY_PROV_INFO_PROP_ID As Long = 2

' Main Function
Function GetIssuedToByIssuedBy(issuerName As String) As String
    Dim hCertStore As LongPtr ' Handle to the certificate store
    Dim pCertContext As LongPtr ' Pointer to the certificate context
    Dim certName As String ' Buffer to store the certificate name
    Dim certNameLength As Long ' Length of the certificate name
    Dim issuerDN As String ' Buffer to store the issuer DN
    Dim result As String ' Result to return
    Dim isSmartCard As Boolean ' Flag to check if the certificate is a Smart Card certificate
    
    ' Open the certificate store (personal certificates)
    hCertStore = CertOpenSystemStore(0, "MY") ' "MY" is the personal certificate store
    If hCertStore = 0 Then
        GetIssuedToByIssuedBy = "Error opening certificate store."
        Exit Function
    End If
    
    ' Find the first certificate in the store
    pCertContext = CertFindCertificateInStore(hCertStore, X509_ASN_ENCODING, 0, CERT_FIND_ANY, 0, 0)
    
    ' Loop through all certificates in the store
    Do While pCertContext <> 0
        ' Get the issuer DN
        issuerDN = String(256, 0) ' Initialize a buffer for the issuer DN
        certNameLength = CertGetNameString(pCertContext, CERT_NAME_SIMPLE_DISPLAY_TYPE, 1, 0, issuerDN, Len(issuerDN))
        issuerDN = Left(issuerDN, certNameLength - 1) ' Remove the null character at the end
        
        ' Check if the provided issuer name is part of the issuer DN
        If InStr(1, issuerDN, issuerName, vbTextCompare) > 0 Then
            ' Check if the certificate is a Smart Card certificate
            isSmartCard = IsSmartCardCertificate(pCertContext)
            
            If isSmartCard Then
                ' Get the "Issued To" value (Subject Name)
                certName = String(256, 0) ' Initialize a buffer for the name
                certNameLength = CertGetNameString(pCertContext, CERT_NAME_SIMPLE_DISPLAY_TYPE, 0, 0, certName, Len(certName))
                If certNameLength > 1 Then
                    result = Left(certName, certNameLength - 1) ' Remove the null character at the end
                Else
                    result = "Subject name not found."
                End If
                Exit Do
            End If
        End If
        
        ' Find the next certificate in the store
        pCertContext = CertFindCertificateInStore(hCertStore, X509_ASN_ENCODING, 0, CERT_FIND_ANY, 0, pCertContext)
    Loop
    
    ' Close the certificate store
    CertCloseStore hCertStore, 0
    
    ' Return the result
    If result <> "" Then
        GetIssuedToByIssuedBy = result
    Else
        GetIssuedToByIssuedBy = "No Smart Card certificate found for issuer: " & issuerName
    End If
End Function

' Function to check if the certificate is a Smart Card certificate
Function IsSmartCardCertificate(pCertContext As LongPtr) As Boolean
    Dim cbData As Long
    Dim provInfo As String
    Dim isSmartCard As Boolean
    
    ' Get the size of the key provider information
    If CertGetCertificateContextProperty(pCertContext, CERT_KEY_PROV_INFO_PROP_ID, 0, cbData) = 0 Then
        IsSmartCardCertificate = False
        Exit Function
    End If
    
    ' Get the key provider information
    provInfo = String(cbData, 0)
    If CertGetCertificateContextProperty(pCertContext, CERT_KEY_PROV_INFO_PROP_ID, StrPtr(provInfo), cbData) = 0 Then
        IsSmartCardCertificate = False
        Exit Function
    End If
    
    ' Check if the provider is a Smart Card provider
    If InStr(1, provInfo, "Smart Card", vbTextCompare) > 0 Then
        isSmartCard = True
    Else
        isSmartCard = False
    End If
    
    IsSmartCardCertificate = isSmartCard
End Function
                        
                        Sub TestGetIssuedToByIssuedByPedrao()
    Dim issuerName As String
    Dim issuedTo As String
    
    ' Set the issuer name (partial match)
    issuerName = "My Issuer"
    
    ' Call the function to get the "Issued To" value
    issuedTo = GetIssuedToByIssuedBy(issuerName)
    
    ' Display the result
    If issuedTo <> "" Then
        MsgBox "Issued To: " & issuedTo
    Else
        MsgBox "No certificate found for issuer: " & issuerName
    End If
End Sub    
                        
                        
 

Function ExtractTextInParentheses(inputText As String) As String
Dim regex As Object
Dim matches As Object
Dim result As String

' Create the RegExp object
Set regex = CreateObject("VBScript.RegExp")

' Configure the regex pattern
regex.IgnoreCase = True ' Case-insensitive search
regex.Global = False ' Search for the first match only
regex.Pattern = "\(([^)]+)\)" ' Pattern to find text between parentheses

' Execute the regex search
Set matches = regex.Execute(inputText)

' Check if there are any matches
If matches.Count > 0 Then
    ' Get the first captured group (text inside parentheses)
    result = matches(0).SubMatches(0)
Else
    result = "" ' Return empty if no match is found
End If

' Return the result
ExtractTextInParentheses = result

End Function