Certificates.vba

Private Declare PtrSafe Function CertOpenStore Lib "Crypt32.dll" ( _
    ByVal lpszStoreProvider As String, _
    ByVal dwEncodingType As Long, _
    ByVal hCryptProv As LongPtr, _
    ByVal dwFlags As Long, _
    ByVal pvPara As LongPtr) As LongPtr

Private Declare PtrSafe Function CertCloseStore Lib "Crypt32.dll" ( _
    ByVal hCertStore As LongPtr, _
    ByVal dwFlags As Long) As Long

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 "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 CertFreeCertificateContext Lib "Crypt32.dll" ( _
    ByVal pCertContext As LongPtr) As Long

Function EncontrarCertificadoPorEmissor(ByVal emissorProcurado As String) As String
    Const CERT_STORE_PROV_SYSTEM As String = "System"
    Const CERT_SYSTEM_STORE_CURRENT_USER As Long = &H10000
    Const CERT_NAME_SIMPLE_DISPLAY_TYPE As Long = 4
    Const CERT_NAME_ISSUER_FLAG As Long = &H1 ' Para obter o nome do emissor
    
    Dim hCertStore As LongPtr
    Dim pCertContext As LongPtr
    Dim szName As String * 256
    Dim szIssuer As String * 256
    Dim nameLength As Long
    Dim issuerLength As Long
    
    ' Abrir a store "My" (Pessoal)
    hCertStore = CertOpenStore(CERT_STORE_PROV_SYSTEM, 0, 0, CERT_SYSTEM_STORE_CURRENT_USER, StrPtr("My"))
    
    If hCertStore = 0 Then
        EncontrarCertificadoPorEmissor = "Erro ao abrir a store de certificados!"
        Exit Function
    End If
    
    ' Enumera os certificados na store
    pCertContext = CertEnumCertificatesInStore(hCertStore, 0)
    
    If pCertContext = 0 Then
        CertCloseStore hCertStore, 0
        EncontrarCertificadoPorEmissor = "Nenhum certificado encontrado!"
        Exit Function
    End If
    
    Do While pCertContext <> 0
        ' Obtém o nome do emissor
        issuerLength = CertGetNameString(pCertContext, CERT_NAME_SIMPLE_DISPLAY_TYPE, CERT_NAME_ISSUER_FLAG, 0, szIssuer, Len(szIssuer))
        
        ' Se o emissor for "Teste", retorna o certificado e para o loop
        If issuerLength > 1 And Left(szIssuer, issuerLength - 1) = emissorProcurado Then
            nameLength = CertGetNameString(pCertContext, CERT_NAME_SIMPLE_DISPLAY_TYPE, 0, 0, szName, Len(szName))
            EncontrarCertificadoPorEmissor = "Certificado encontrado: " & Left(szName, nameLength - 1)
            CertCloseStore hCertStore, 0
            Exit Function
        End If
        
        ' Obtém o próximo certificado
        pCertContext = CertEnumCertificatesInStore(hCertStore, pCertContext)
    Loop
    
    ' Fecha a store de certificados
    CertCloseStore hCertStore, 0
    
    EncontrarCertificadoPorEmissor = "Nenhum certificado encontrado com emissor '" & emissorProcurado & "'"
End Function

Sub TestarBuscaCertificado()
    Dim resultado As String
    resultado = EncontrarCertificadoPorEmissor("Teste")
    MsgBox resultado, vbInformation, "Resultado da Busca"
End Sub