(Это более подробное обсуждение проблемы в Определение правильного сертификата клиента для ServerXMLHTTP. SetOption, где я попробовал обходной путь, который столкнулся с различными проблемами.)
Я пытаюсь восстановить возможности серверной веб-службы в базе данных MS Access после того, как веб-сервер перешел на аутентификацию STS на основе сертификатов. Я должен использовать VBA.
У меня есть последовательность веб-вызовов и ожидаемых заголовков и файлов cookie, но я не могу успешно прикрепить сертификат клиента к дескриптору запроса, используя WinHTTP или WinINet. (Мне нужно использовать функции, а не COM-интерфейс, из-за необходимости обрабатывать возвращаемые файлы cookie сервера.)
Попытка использовать InternetSetOption с дескриптором контекста сертификата клиента приводит к сбою с жестким дампом на рабочий стол. Я думаю, что у меня неправильный размер параметра lpdwBufferLength, но я не уверен.
' 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
