Usar VBA para adjuntar un certificado de cliente a WinINet HTTPSendRequest

ms-access access-vba

Question

(Esta es una discusión más amplia del problema en Identificar el certificado de cliente correcto para ServerXMLHTTP.SetOption , donde probé una solución alternativa que se encontró con diferentes problemas).

Estoy intentando restaurar una función de servicio web de fondo en una base de datos de MS Access después de que el servidor web se movió a la autenticación STS basada en certificados. Debo usar VBA.

Tengo lista la secuencia de llamadas web y las declaraciones esperadas de encabezado y cookie, pero no puedo adjuntar el certificado del cliente al identificador de solicitud con éxito usando WinHTTP o WinINet. (Necesito usar las funciones y no la interfaz COM, debido a la necesidad de manejar las cookies del servidor devuelto).

Intentar utilizar InternetSetOption con el identificador de contexto del certificado del cliente falla con un volcado en el escritorio. Creo que tengo el tamaño incorrecto para el parámetro lpdwBufferLength, pero no estoy seguro.

'' All API declares
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
    ByVal lpszAgent As String, _
    ByVal dwAccessType As Long, _
    ByVal lpszProxyName As String, _
    ByVal lpszProxyBypass As String, _
    ByVal dwFlags As Long) As Long

Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
    ByVal hInternetSession As Long, _
    ByVal lpszServerName As String, _
    ByVal nServerPort As Integer, _
    ByVal lpszUsername As String, _
    ByVal lpszPassword As String, _
    ByVal dwService As Long, _
    ByVal dwFlags As Long, _
    ByVal dwContext As Long) As Long

Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" ( _
    ByVal hHttpSession As Long, _
    ByVal lpszVerb As String, _
    ByVal lpszObjectName As String, _
    ByVal lpszVersion As String, _
    ByVal lpszReferer As String, _
    ByVal lpszAcceptTypes As String, _
    ByVal dwFlags As Long, _
    ByVal dwContext As Long) As Long

Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" ( _
    ByVal hHttpRequest As Long, _
    ByVal lpszHeaders As String, _
    ByVal dwHeadersLength As Long, _
    ByVal lpOptional As String, _
    ByVal dwOptionalLength As Long) As Boolean

Private Declare Function InternetSetOption Lib "wininet.dll" ( _
    ByVal hInternet As IntPtr, ByVal dwOption As Integer, _
    ByVal lpBuffer As IntPtr, ByVal lpdwBufferLength As Integer) As Boolean

Private Declare Function CertOpenSystemStore Lib "Crypt32.dll" Alias "CertOpenSystemStoreA" (ByVal hCryptProv As Long, _
    ByVal pvFindPara As String) As Long

Private Declare Function CryptUIDlgSelectCertificateFromStore Lib "cryptui.dll" ( _
    ByVal hCertStore as Long, ByVal hwnd as Long, byRef pwszTitle as String, _
    ByRef pwszDisplayString as String, ByVal dwDontUseColumn as Long, _
    ByVal dwFlags as Long, ByVal pvReserved as Any) as Long

Private Declare Function CertFreeCertificateContext Lib "crypt32.dll" ( _
    ByVal pCertContext as Long) as Long

Private Declare Function CertCloseStore lib "crypt32.dll" ( _
    ByVal hCertStore as Long, ByVal dwFlags as Long) as Long

'' All API constants ...
'' ....
Const INTERNET_OPTION_CLIENT_CERT_CONTEXT = 84
Const CRYPTUI_SELECT_LOCATION_COLUMN = 16
Const ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED = 12044
Const INTERNET_FLAG_SECURE = &H800000
Const INTERNET_FLAG_IGNORE_CERT_CN_INVALID = &H1000
Const INTERNET_SERVICE_HTTP = 3
Const INTERNET_DEFAULT_HTTPS_PORT = 443
Const INTERNET_OPEN_TYPE_PRECONFIG = 0

Private Type CERT_CONTEXT
    dwCertEncodingType as Long
    pbCertEncoded as Long
    cbCertEncoded as Long
    pCertInfo as Long
    hCertStore as Long
End type


'' Test routine

Private Sub TestHTTPCert(myURL as String)
    Dim hISession as Long, hIConnect as Long, hRequest as Long, hCert as Long, hStore as Long
    Dim myURLStart as String, myURLEnd as String
    Dim lgRep as Long, myCERT_CONTEXT as CERT_CONTEXT
    Dim lpszHeaders as String

    '' Open the session using the WININET API
    '' Should I be using an lpszAgent = "Mozilla/5.0 (compatible)" ??
    hISession = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_PRECONFIG, _
                             vbNullString, vbNullString, 0)

    if CBool(hISession) then

        '' Separate the server and the destination
        myURLStart = Replace(lcase(myURL),"https://",vbNullString)
        myURLEnd = myURLStart
        myURLStart = Left(myURLStart,InStr(1,myURLStart,"/")-1)
        myURLEnd = Mid(myURLEnd,InStr(1,myURLEnd,"/")+1)

        '' Begin the internet connection using WININET API
        hIConnect = InternetConnect(hISession,myURLStart,INTERNET_DEFAULT_HTTPS_PORT, _
                                    vbNullString,vbNullString,INTERNET_SERVICE_HTTP,0,0)

        '' Begin the HTTP request using the WININET API
        hRequest = HttpOpenRequest(hIConnect,"GET",myURLEnd,vbNullString,0, _
                       INTERNET_FLAG_SECURE Or INTERNET_FLAG_IGNORE_CERT_CN_INVALID,0)

        '' Set an additional header
        lpszHeaders = "Content-Type: application/x-www-form-urlencoded" & Chr(0)

        '' Try sending the request, expecting a CERT_NEEDED error
        HttpSendRequest hRequest, lpszHeaders, len(lpszHeaders), vbNullString, 0

        '' Handle the expected CERT_NEEDED error
        if Err.LastDLLError = ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED then

            '' Open the certificate store
            hStore = CertOpenSystemStore(0, "MY")

            if Not IsNull(hStore) then
                '' Use the CryptUI API to select the right certicate
                hCert = CryptUIDlgSelectCertificateFromStore(hStore, 0&, vbNullString, vbNullString, CRYPTUI_SELECT_LOCATION_COLUMN, 0, 0&)

                '' Attempt to attach the context to the hRequest handle
                '' FAILS WITH APPLICATION DUMP TO DESKTOP
                InternetSetOption hRequest, INTERNET_OPTION_CLIENT_CERT_CONTEXT, hCert, len(myCERT_CONTEXT)

                CertFreeCertificateContext hCert
                CertCloseStore hStore, 0

                '' Retry the HttpSendRequest
                HttpSendRequest hRequest, lpszHeaders, len(lpszHeaders), vbNullString, 0

                '' Check the headers for expected returns and required cookies
                '' .
                '' .
                '' .
                '' Close all handles etc etc
            End If
        End If
    End If
End Sub