Using VBA to attach a client certificate to a WinI

Question

(This is a more expansive discussion of the problem in Identifying correct client certificate for ServerXMLHTTP.SetOption, where I tried a workaround that ran into different problems.)

I am attempting to restore a back-end web service capability in an MS Access database after the web server moved to certificate-based STS authentication. I must use VBA.

I have the sequence of web calls and expected header and cookie returns ready, but I am unable to attach the client certificate to the request handle successfully using either WinHTTP or WinINet. (I need to use the functions and not the COM interface, because of the need to handle the returned server cookies.)

Attempting to use InternetSetOption with the client certificate's context handle fails with a hard-dump to the desktop. I think I've got the wrong size for the lpdwBufferLength parameter, but I am not sure.

' 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