Visual Basic Forum for Visual Basic Programmers VB

[emilio-Ingematica]

Hi,

I am trying to access to a Certificate with winInet.dll but it does not work.
I have this code in a excel file with a Macro, if you put a button on the worksheet and run Connect(), you will see that the Excel will close itself.
Can anybody help me?

regards


Option Explicit
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_OPEN_TYPE_DIRECT = 1
Private Const INTERNET_OPEN_TYPE_PROXY = 3
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_FLAG_SECURE = "&H00800000"

Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Public Type INTERNET_CERTIFICATE_INFO
ftExpiry As FILETIME
ftStart As FILETIME
lpszSubjectInfo As String
lpszIssuerInfo As String
lpszProtocolName As String
lpszSignatureAlgName As String
lpszEncryptionAlgName As String
dwKeySize As Long
End Type

Public Type INTERNET_VERSION_INFO
dwMajorVersion As Long
dwMinorVersion As Long
End Type

Private Const INTERNET_OPTION_SECURITY_CERTIFICATE_STRUCT = 32
Private Const INTERNET_OPTION_SECURITY_CERTIFICATE = 35


Private Const scUserAgent = "VB Project"
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hOpen As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetGetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function HttpOpenRequest Lib "wininet.dll" Alias "HttpOpenRequestA" (ByVal hHttpSession As Long, ByVal sVerb As String, ByVal sObjectName As String, ByVal sVersion As String, ByVal sReferer As String, ByVal something As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetQueryOption Lib "wininet.dll" Alias "InternetQueryOptionA" (ByVal HINTERNET As Long, ByVal lOption As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long) As Integer
Private Declare Function HttpSendRequest Lib "wininet.dll" Alias "HttpSendRequestA" (ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, sOptional As Any, ByVal lOptionalLength As Long) As Long


Public Sub Connect()

Dim HINTERNET As Long
Dim hInstance As Long
Dim hSession As Long
Dim hRequest As Long
Dim hReq As Long
Dim lngRet As Long
Dim HtmlVersion As INTERNET_VERSION_INFO
Dim sBuffer As String
Dim sBufferSize As Long
Dim Cert As INTERNET_CERTIFICATE_INFO
Dim CertSize As Long
Dim bres As Long
Dim VersionInfo As INTERNET_VERSION_INFO
Dim VerInfoSize As Long

Dim strObject As String

hInstance = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, vbNullString, 0)

hSession = InternetConnect(hInstance, "microsoftactividades.ingematica.com.ar", 443, _
vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)

Call CrackURL("https://microsoftactividades.ingematica.com.ar", strObject)

hRequest = HttpOpenRequest(hSession, "GET", strObject, _
"HTTP/1.0", vbNullString, 0, INTERNET_FLAG_SECURE, 0)

If CBool(hRequest) Then
If HttpSendRequest(hRequest, vbNullString, 0, 0, 0) Then
Else
MsgBox ("Error with HttpSendRequest " & Err.LastDllError)
End If
If Err.LastDllError = 0 Then

'*********************************************************************************
'*** It is in these two instructions where i can not obtain the info of the certificate - From here '*********************************************************************************

Call InternetQueryOption(hRequest, _
INTERNET_OPTION_SECURITY_CERTIFICATE, _
Null, _
CertSize)

Dim strinfo As String
strinfo = Space$(CertSize)


If InternetQueryOption(hRequest, _
INTERNET_OPTION_SECURITY_CERTIFICATE, _
strinfo, _
CertSize) Then
Else
MsgBox ("Problem with SecurityCertStruct 2 " & Err.LastDllError)
End If

'*********************************************************************************
'*** To here '*********************************************************************************


MsgBox (Cert.lpszIssuerInfo)
'MsgBox (Cert.ftStart)
End If
Else
' HttpOpenRequest failed
MsgBox ("HttpOpenRequest call failed; Error code: " & Err.LastDllError & ".")
End If

End Sub

Public Sub CrackURL(strURL As String, strFilePath As String)

Dim intPos As Integer

If Left$(strURL, 7) = "http://" Then
strURL = Right$(strURL, Len(strURL) - 7)
Else
If Left$(strURL, = "https://" Then
strURL = Right$(strURL, Len(strURL) -
End If
End If

intPos = InStr(1, strURL, "/")

If intPos > 0 Then
strFilePath = Right$(strURL, Len(strURL) - intPos + 1)
strURL = Left$(strURL, intPos - 1)
End If

End Sub