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