I am trying to connect to a Web Database with the following code, but it does not seem to work when automated in VBA. The login and password are fine as I can connect manually with them.
is it possible that the Object: "WinHttp.WinHttpRequest.5.1" does not work with this sort of database connection? Or maybe am I missing a parameter in my Connect sub? Any help on this matter would be greatly appreciated.
Sub Connect()
Dim oHttp As Object
Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
Call oHttp.Open("GET", "http://qrdweb/mg/loan/loans.html?show=all", False)
oHttp.setRequestHeader "Content-Type", "application/xml"
oHttp.setRequestHeader "Accept", "application/xml"
oHttp.setRequestHeader "Authorization", "Basic " + Base64Encode("login123" + ":" + "pass123")
Call oHttp.send
Sheets("Sheet1").Cells(1, 1).Value = oHttp.getAllResponseHeaders
Sheets("Sheet1").Cells(1, 2).Value = oHttp.ResponseText
End Sub
Private Function Base64Encode(sText)
Dim oXML, oNode
Set oXML = CreateObject("Msxml2.DOMDocument.3.0")
Set oNode = oXML.createElement("base64")
oNode.DataType = "bin.base64"
oNode.nodeTypedValue = StringToBinary(sText)
Base64Encode = oNode.Text
Set oNode = Nothing
Set oXML = Nothing
End Function
Private Function StringToBinary(Text)
Const adTypeText = 2
Const adTypeBinary = 1
Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Type = adTypeText
BinaryStream.Charset = "us-ascii"
BinaryStream.Open
BinaryStream.WriteText Text
'Change stream type To binary
BinaryStream.Position = 0
BinaryStream.Type = adTypeBinary
'Ignore first two bytes - sign of
BinaryStream.Position = 0
StringToBinary = BinaryStream.Read
Set BinaryStream = Nothing
End Function
The oHttp.getAllResponseHeaders displaying the getAllresponseHeaders outputs the following information:
Cache-Control: must-revalidate,no-cache,no-store
Connection: keep-alive
Date: Fri, 24 Feb 2017 17:19:54 GMT
Content-Length: 30633
Content-Type: text/html;charset=ISO-8859-1
Server: nginx/1.11.6
WWW-Authenticate: Digest realm="QRDWEB-MNM", domain="", nonce="aB5DLmvuCfok9Zo112jo4S0evgOuXntE", algorithm=MD5, qop="auth", stale=true
While the oHttp.ResponseText displaying the ResponseText outputs the following information:
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=ISO-8859-1"/>
<title>Error 401 Server Error</title>
</head>
<body>
Edit 1
When I comment out the 3 lines of code containing: oHttp.setRequestHeader, and changing the line: Set oHttp = CreateObject("WinHttp.WinHttpRequest.5.1") by Set oHttp = CreateObject("MSXML2.XMLHTTP"), a pop up appears for a login and password. If I fill in the information the following responses are different:
The oHttp.getAllResponseHeaders displaying the getAllresponseHeaders outputs the following information:
Server: nginx/1.11.6
Date: Fri, 24 Feb 2017 18:19:02 GMT
Transfer-Encoding: chunked
Connection: keep-alive
While the oHttp.ResponseText displaying the ResponseText outputs the following information:
<html>
<head>
<title>M&M - Loan Viewer</title>
<script language="javascript" type="text/javascript">
function showTransactionComments(loanId, date, type, commentsTableWidth) {
//alert(loanId + " " + date + " " + type + " " + commentsTableWidth);
if (window.ActiveXObject) {
return;
Edit 2
I am now attempting to integrate Digest Authentication into VBA with the following sub and I get 2 possible outcomes: The first outcome is the same 401 error when using the wrong login info and the return is immediate. However, when I provide the proper login info, the operation times out... What could be causing that?
Sub digest()
Dim http As New WinHttpRequest
Dim strResponse As String
Set http = New WinHttpRequest
http.Open "GET", "http://qrdweb/mg/loan/loans.html?show=all", False
http.SetCredentials "login123", "pass123", HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
http.send
Sheets("Sheet1").Cells(1, 1).Value = http.getAllResponseHeaders
Sheets("Sheet1").Cells(1, 2).Value = http.ResponseText
http.Open "PROPFIND", "http://qrdweb/mg/loan/loans.html?show=all", False
http.send
End Sub
Per the Microsoft docs, the JScript example, it looks like authentication requires two sucessive Open/Send pairs on the same connection. The first tells the HTTP request object that Digest authentication is required, and the second actually does it. Try this (not tested):
Sub digest()
Dim http As WinHttpRequest ' *** Not "New" - you do it below
Dim strResponse As String
Set http = New WinHttpRequest
http.Open "GET", "http://qrdweb/mg/loan/loans.html?show=all", False
http.Send ' *** Try it without authentication first
if http.Status <> 401 then Exit Sub ' *** Or do something else
http.Open "GET", "http://qrdweb/mg/loan/loans.html?show=all", False
' *** Another Open, same as the JScript example
http.SetCredentials "login123", "pass123", HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
http.Send
MsgBox CStr(http.Status) & ": " & http.StatusText ' *** Just to check
Sheets("Sheet1").Cells(1, 1).Value = http.getAllResponseHeaders
Sheets("Sheet1").Cells(1, 2).Value = http.ResponseText
' *** Not sure what these two lines are for --- I have commented them out
'http.Open "PROPFIND", "http://qrdweb/mg/loan/loans.html?show=all", False
'http.send
End Sub
Related
I am attempting to access the Appointments-Plus.com API via VBA code and am consistently being told I'm giving it an invalid site-id/key. I'm using Access from the Office365 version.
This is the relevant documentation for this API call.
When I use Postman to test out the API, I am able to successfully connect and I get data back. The URL Postman puts together is this:
https://ws.appointment-plus.com/Locations/GetLocations?Authorization:Basic=<site-ID>:<Key>&response_type=xml
My VBA code is this:
Public Sub RESTtestBigURL()
Dim responseType As String
responseType = "response_type=json"
Dim restRequest As WinHttp.WinHttpRequest
Set restRequest = New WinHttp.WinHttpRequest
Dim restResult As String
With restRequest
.Open "POST", "https://ws.appointment-plus.com/Locations/GetLocations?Authorization:Basic=<site-ID>:<Key>&response_type=xml", False
.Send
.WaitForResponse
Debug.Print ".ResponseText: " & .ResponseText
Debug.Print ".Status: " & .Status
Debug.Print ".StatusText: " & .StatusText
Debug.Print ".ResponseBody: " & .ResponseBody
End With
End Sub
I know that the first question is "are you sure you've got the <site-ID> and <key> correct???" Yes - I've copy/pasted the entire URL from Postman into my VBA code, and I've had another couple of pairs of eyeballs review it to confirm that they're still the same.
When I run that code, I get:
.ResponseText: <?xml version="1.0" encoding="utf-8" ?>
<APResponse>
<resource>customers</resource>
<action>getcustomers</action>
<request></request>
<result>fail</result>
<count>0</count>
<errors>
<error><![CDATA[Web Services authentication failed: invalid Site ID or API Key]]></error>
</errors>
</APResponse>
I've tried several other methods of accessing the API, all of which are giving me the same "Invalid ID/Key" error:
Public Sub SecondRESTtestMSXML()
Dim restRequest As MSXML2.XMLHTTP60
Set restRequest = New MSXML2.XMLHTTP60
With restRequest
.Open "GET", URL & REQUEST_GET_LOCATIONS, True
.SetRequestHeader "Authorization", "Basic" & SITE_ID & ":" & API_KEY
.SetRequestHeader "response_type", "xml"
.SetRequestHeader "Accept-Encoding", "application/xml"
.Send "{""response_type"":""JSON""&""location"":""582""}"
While .ReadyState <> 4
DoEvents
Wend
Debug.Print ".ResponseText: " & .ResponseText
Debug.Print ".Status: " & .Status
Debug.Print ".StatusText: " & .StatusText
Debug.Print ".ResponseBody: " & .ResponseBody
End With
End Sub
There is a suggestion that this is a duplicate of another question that was resolved by Base64-encoding. However, this method, while it wasn't explicit, shows that I have attempted that, too. I've added the Base64Encode function code that is called from here.
Public Sub RESTtest()
Dim restRequest As WinHttp.WinHttpRequest
Set restRequest = New WinHttp.WinHttpRequest
Dim restResult As String
With restRequest
.Open "POST", URL & REQUEST_GET_LOCATIONS, True
.SetRequestHeader "Authorization", "Basic " & SITE_ID & ":" & Base64Encode(API_KEY)
' Note call to Base64Encode() on this line ---------------- ----- ^^^^^^^^^^^^
.Option(WinHttpRequestOption_EnableRedirects) = False
.Send "{""response_type"":""JSON""}"
.WaitForResponse
Debug.Print ".ResponseText: " & .ResponseText
Debug.Print ".Status: " & .Status
Debug.Print ".StatusText: " & .StatusText
Debug.Print ".ResponseBody: " & .ResponseBody
End With
End Sub
Public Function Base64Encode(ByVal inputText As String) As String
Dim xmlDoc As Object
Dim docNode As Variant
Set xmlDoc = CreateObject("Msxml2.DOMDocument.3.0")
Set docNode = xmlDoc.createElement("base64")
docNode.DataType = "bin.base64"
docNode.nodeTypedValue = Stream_StringToBinary(inputText)
Base64Encode = docNode.Text
Set docNode = Nothing
Set xmlDoc = Nothing
End Function
Notes:
URL, REQUEST_GET_LOCATIONS, SITE_ID, and API_KEY are constants declared globally in this module for testing purposes. They, too, have all been copy/pasta'd and reviewed by several people for typos.
You may note that there are requests for responses in both XML and JSON - they're both giving me the same response.
I do have a support ticket open with Appt Plus, but I'm hoping I might get a faster response here.
Are there any obvious errors that anyone sees in this code? Are there any suggestions for other methods to attempt to call the API and get results? I've had a suggestion to write a DLL in C# and call that, however, I don't have the time to learn enough C# to make that happen, so switching languages isn't really an option here.
Additional notes:
I tried this using curl in a Powershell session, and it gives me the same result:
PS H:\> curl -method Post -uri "https://ws.appointment-plus.com/Locations/GetLocations?Authorization:Basic=<ID>:<key>&response_type=json"
The result:
StatusCode : 200
StatusDescription : OK
Content : {"resource":"locations",
"action":"getlocations",
"request":"",
"result":"fail",
"count":"0"
,"errors":[
"Web Services authentication failed: invalid Site ID or API ...
RawContent : HTTP/1.1 200 OK
Pragma: no-cache
Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0
Date: Mon, 26 Aug 2019 17:28:41 GMT
Expires: Thu, 19 Nov 1981 08:52:00 GMT
Set-Cooki...
Forms : {}
Headers : {[Pragma, no-cache], [Cache-Control, no-store, no-cache, must-revalidate, post-check=0,
pre-check=0], [Date, Mon, 26 Aug 2019 17:28:41 GMT], [Expires, Thu, 19 Nov 1981 08:52:00 GMT]...}
Images : {}
InputFields : {}
Links : {}
ParsedHtml : mshtml.HTMLDocumentClass
RawContentLength : 207
Per the exchanges in the comments, the main issue appears to be how the basic authorization header was being formed.
For future readers, the format for the authorization header is:
.SetRequestHeader "Authorization", "Basic " & Base64Encode(SITE_ID & ":" & API_KEY)
Also, another issue you may run into is related here. Linebreaks are inserted into the Base64 encoded string with the current approach, which won't play nice with most (if not all) APIs. A suggested fix for this would be something like:
Public Function Base64Encode(ByVal inputText As String, Optional removeBlankLines = True) As String
Dim xmlDoc As Object
Dim docNode As Variant
Set xmlDoc = CreateObject("Msxml2.DOMDocument.3.0")
Set docNode = xmlDoc.createElement("base64")
docNode.DataType = "bin.base64"
docNode.nodeTypedValue = Stream_StringToBinary(inputText)
Base64Encode = docNode.Text
Set docNode = Nothing
Set xmlDoc = Nothing
'remove blank line characters ASCII --> 10,13,10 + 13
If removeBlankLines Then Base64Encode = Replace(Replace(Replace(Base64Encode, vbCrLf, vbNullString), vbLf, vbNullString), vbCr, vbNullString)
End Function
I want to request a token from a web service. It requires I make an HTTP "POST" request using an authorization code.
I need to include this code, among other parameters in my request.
Any detail I find online formats the request in Java as follows (all IDs are faked):
POST /services/oauth2/token HTTP/1.1
Host: "YourURL.com"
grant_type=authorization_code&code=aPrxsmIEeqM9PiQroGEWx1UiMQd95_5JUZ
VEhsOFhS8EVvbfYBBJli2W5fn3zbo.8hojaNW_1g%3D%3D&client_id=3MVG9lKcPoNI
NVBIPJjdw1J9LLM82HnFVVX19KY1uA5mu0QqEWhqKpoW3svG3XHrXDiCQjK1mdgAvhCs
cA9GE&client_secret=1955279925675241571&
redirect_uri=https%3A%2F%2Fwww.mysite.com%2Fcode_callback.jsp
How do I produce a request like this?
Below are the relevant components of my code:
Dim request As WinHttp.WinHttpRequest
Dim
client_id,
redirect_uri,
grant_type,
client_secret,
authcode,
result,
token_url,
As String
Sub testmod()
Set request = New WinHttp.WinHttpRequest
client_id = "MyClientID"
client_secret = "MyClientSecret"
grant_type = "authorization_code"
redirect_uri = "MyRedirectURI"
authcode = "MyAuthorizationCode"
token_url = "MyTokenURL" <--- No specified query string appended
With request
.Open method:="POST", Url:=token_url
''''Including POST Params with Send method''''
.Send ("{""code"":" & authcode &
",""grant_type"":authorization_code,""client_id"":" & client_id &
",""client_secret"":" & client_secret & ",""redirect_uri"":" &
redirect_uri & "}")
''''This returns error code 400 denoting a bad request''''
Debug.Print .StatusText
end with
end sub
Any idea why these parameters are causing this request to fail?
I don't know what API you are referring to, whereas there is a new API in which the oldest 'guide' is dated 'Mar' presumably 2019.
https://developer.tdameritrade.com/apis
https://developer.tdameritrade.com/guides
Wherein there is NO reference to the "&client_secret=" being needed !.
In the 'latest' API, you request the 'code' as follows directly into your browser. It is good got a very few minutes.
https://auth.tdameritrade.com/oauth?
client_id=XXXX#AMER.OAUTHAP&response_type=code&redirect_uri=https://192.168.0.100
The response appears in the browser's entry, not in the body, You have to decode the response to use the 'code'. The RefreshToken (90 days valid) & AccessToken (30 minutes valid) are used as the are returned in the ResponseText
To get the 90 day RefreshToken and the first AccessToken
This is VBA which calls Javascript.
Private Sub Get_RefreshToken() 'Good for 90 days, then needs a new 'code', see above, also get the first AccessToken which are good for 30 minutes
Dim code As String 'dcoded, not URL coded 'WAITS for the RESPONSE, NO callback
Dim shtSheetToWork As Worksheet
Set shtSheetToWork = ActiveWorkbook.Sheets("AUTH") '<<== may NEED change
With shtSheetToWork
authorizationcode = .Range(3, "C") // dump into Excel and decode by rows JSON 'split'
Dim xmlhttp As Object
Dim scriptControl As Object
Dim Response, JsonObj As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Set scriptControl = CreateObject("MSScriptControl.ScriptControl")
scriptControl.Language = "JScript"
authUrl = "https://api.tdameritrade.com/v1/oauth2/token"
xmlhttp.Open "Post", authUrl, False
xmlhttp.Send "{grant_type: authorization_code, authorizationcode: ,access_type: offline, client_id: .UserId, redirect_uri: .URLredirect}"
Response = scriptControl.Eval(xmlhttp.responseText)
.Range(4, "C") = Response.refresh_token 'RefreshToken
xmlhttp.setRequestHeader "Authorization", Response.refresh_token
xmlhttp.Send
MsgBox (xmlhttp.responseText)
Select Case xmlhttp.Status
Case 200
Dim i As Integer
Dim strKey As String
Dim strVal As Variant
Dim JsonData As Variant
JsonObj = JsonDate.Parse(xmlhttp.responseText)
Cells(colstr, toprow - 1) = JsonObj
i = 1
Do While Trim(Cells(i, 1)) <> ""
Name = Split(Cells(i, 1).Text, ":")
If Name = "RefreshToken" Then .RefreshToken = Name: .nextRefreshToken = DateAdd("d", 90, Now)
If Name = "AccessToken" Then .AccessToken = Name: .nextAccessToken = DateAdd("m", 30, Now)
Case 400
MsgBox (" validation problem suthorization 'CODE' ")
Stop
Case 401
MsgBox (" Invalid credentials ")
Stop
Case 403
MsgBox (" caller doesn't have access to the account ")
Stop
Case 405
MsgBox (" Response without Allow Header")
Stop
Case 500
MsgBox (" unexpected server error ")
Stop
Case 503
MsgBox ("temporary problem responding, RETRYING !! ")
' WAIT A MINUTE AND RETRY
End Select
Set xmlhttp = Nothing
Set JsonObj = Nothing
End With
End Sub
Private Sub AccessToken() 'WAITS for the RESPONSE, NO callback
Dim code As String 'dcoded, not URL coded
Dim shtSheetToWork As Worksheet
Set shtSheetToWork = ActiveWorkbook.Sheets("AUTH") '<<== may NEED change
With shtSheetToWork
Dim xmlhttp As Object
Dim scriptControl As Object
Dim Response, JsonObj As Object
Set xmlhttp = CreateObject("MSXML2.serverXMLHTTP")
Set scriptControl = CreateObject("MSScriptControl.ScriptControl")
scriptControl.Language = "JScript"
authUrl = "https://api.tdameritrade.com/v1/oauth2/token"
xmlhttp.Open "Post", authUrl, False
xmlhttp.Send "{grant_type: refresh_token, authorizationcode: .RefreshToken, access_type: , client_id: .MYUserId, redirect_uri: }"
Response = scriptControl.Eval(xmlhttp.responseText)
.AccessToken = Response.refresh_token
xmlhttp.setRequestHeader "Authorization", RefreshToken
xmlhttp.Send
'MsgBox (xmlhttp.responseText)
Select Case xmlhttp.Status
Case 200
Dim i As Integer
Private strKey As String
Private strVal As Variant
Private Data As Variant
JsonObj = Json.Parse(xmlhttp.responseText)
Cells(colstr, toprow - 1) = JsonObj
NextText = Cells(colstr, toprow - 1)
JsonObj = Nothing
i = 1
Do While Trim(Cells(i, 1)) <> ""
Name = Split(Cells(i, 1).Text, ":")
If Name = "RefreshToken" Then .RefreshToken = Name: .nextRefreshToken = DateAdd("d", 90, Now)
If Name = "AccessToken" Then .AccessToken = Name: .nextAccessToken = DateAdd("m", 30, Now)
Case 400
MsgBox (" validation problem suthorization 'CODE' ")
Stop
Case 401
MsgBox (" Invalid credentials ")
Stop
Case 403
MsgBox (" caller doesn't have access to the account ")
Stop
Case 405
MsgBox (" Response without Allow Header")
Stop
Case 500
MsgBox (" unexpected server error ")
Stop
Case 503
MsgBox ("temporary problem responding, RETRYING !! ")
' WAIT A MINUTE AND RETRY
End Select
Next i
Set xmlhttp = Nothing
End With
End Sub
After some help from stackoverflow experts I have been able to successfully retrieve my response using SOAP. The below piece is how I received and stored the data. This of course is not all the code. I just included this to show how I later reference the xml.
With xmlhtp
webserviceSOAPActionNameSpace = "http://example.com/webservices/"
.Open "POST", sUrl, False
.setRequestHeader "POST", "https://onesite.example.com/webservices/stuff.asmx HTTP/1.1"
.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
.setRequestHeader "Content-Length", 100
.setRequestHeader "SOAPAction", webserviceSOAPActionNameSpace & "RetrieveData"
.send sEnv
sResult = xmlhtp.statusText
responseText = xmlhtp.responseText
ActiveSheet.Cells(1, 1).Value = .responseText
End With
Debug.Print responseText
Now I am having trouble parsing that out. This seems like it should be pretty simple but I get an error indicating that the responseText I receive above is not "loading" to xmlDOC. The following is at the beginning of the sub:
Dim xmlhtp As New MSXML2.XMLHTTP
Dim xmlDoc As New DOMDocument
Dim XDoc As Object
After the With End (shown above) my code looks like this:
Set XDoc = CreateObject("MSXML2.DOMDocument")
XDoc.async = False: XDoc.validateOnParse = False
XDoc.Load (xmlhtp.responseText)
Set lists = XDoc.DocumentElement
Set getFirstChild = lists.FirstChild
Debug.Print getFirstChild.XML
Debug.Print getFirstChild.Text
On the line
Set getFirstChild = lists.FirstChild
I recieve the following error
Object variable or With block variable not set
When I look at the Local Variable window in VBA I can clearly see that nothing was assigned to xmlDoc. So I assume my problem is in XDoc.Load Line.
Any direction would be appreciated.
use XDoc.LoadXML (xmlhtp.responseText) instead of XDoc.Load (xmlhtp.responseText)
first time posting,
I'm trying to get the ID "dadosDoUsuario" from a website's page I have to be logged in. I got it working using "InternetExplorer.Application" object, but can't get the ID value when using "MSXML2.XMLHTTP" object. It seems it won't go past the login page, since I'm able to get other IDs from this page (example: "tituloPagina"). Could someone give a hint on how I get the data from the page after logged in? Thanks!
InternetExplorer.Application code (this one works):
Sub testIE()
Dim texto As String
Set ie = CreateObject("InternetExplorer.Application")
my_url = "https://www.nfp.fazenda.sp.gov.br/login.aspx"
With ie
.Visible = False
.Navigate my_url
Do Until Not ie.Busy And ie.readyState = 4
DoEvents
Loop
End With
ie.Document.getelementbyid("userName").Value = "MYUSERNAME"
ie.Document.getelementbyid("Password").Value = "MYPASSWORD"
ie.Document.getelementbyid("Login").Click
Do Until Not ie.Busy And ie.readyState = 4
DoEvents
Loop
ie.Document.getelementbyid("btnConsultarNFSemestre").Click
Do Until Not ie.Busy And ie.readyState = 4
DoEvents
Loop
texto = ie.Document.getelementbyid("dadosDoUsuario").innerText
MsgBox texto
ie.Quit
End Sub
MSXML2.XMLHTTP code (this one doesn't work):
Sub testXMLHTTP()
Dim xml As Object
Dim html As Object
Dim dados As Object
Dim text As Object
Set xml = CreateObject("MSXML2.XMLHTTP")
Set html = CreateObject("htmlFile")
With xml
.Open "POST", "https://www.nfp.fazenda.sp.gov.br/Login.aspx", False
.setRequestHeader "Content-Type", "text/xml"
.send "userName=MYUSERNAME&password=MYPASSWORD"
.Open "GET", "https://www.nfp.fazenda.sp.gov.br/Inicio.aspx", False
.setRequestHeader "Content-Type", "text/xml"
.send
End With
html.body.innerhtml = xml.responseText
Set objResult = html.GetElementById("dadosDoUsuario")
GetElementById = objResult.innertext
MsgBox GetElementById
End Sub
EDIT: I followed the steps suggested by #Florent B., and added a scripcontrol to get the encoded values for __VIEWSTATE, __VIEWSTATEGENERATOR and __EVENTVALIDATION. Got it working!
Sub testXMLHTTP()
Dim xml As Object
Dim html As HTMLDocument
Dim dados As Object
Dim text As Object
Dim html2 As HTMLDocument
Dim xml2 As Object
Set xml = CreateObject("Msxml2.ServerXMLHTTP.6.0")
Set html = CreateObject("htmlFile")
With xml
.Open "GET", "https://www.nfp.fazenda.sp.gov.br/Login.aspx", False
.send
End With
strCookie = xml.getResponseHeader("Set-Cookie")
html.body.innerhtml = xml.responseText
Set objvstate = html.GetElementById("__VIEWSTATE")
Set objvstategen = html.GetElementById("__VIEWSTATEGENERATOR")
Set objeventval = html.GetElementById("__EVENTVALIDATION")
vstate = objvstate.Value
vstategen = objvstategen.Value
eventval = objeventval.Value
'URL Encode ViewState
Dim ScriptEngine As ScriptControl
Set ScriptEngine = New ScriptControl
ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function encode(vstate) {return encodeURIComponent(vstate);}"
Dim encoded As String
encoded = ScriptEngine.Run("encode", vstate)
vstate = encoded
'URL Encode Event Validation
ScriptEngine.AddCode "function encode(eventval) {return encodeURIComponent(eventval);}"
encoded = ScriptEngine.Run("encode", eventval)
eventval = encoded
'URL Encode ViewState Generator
ScriptEngine.AddCode "function encode(vstategen) {return encodeURIComponent(vstategen);}"
encoded = ScriptEngine.Run("encode", vstategen)
vstategen = encoded
Postdata = "__EVENTTARGET=" & "&__EVENTARGUMENT=" & "&__VIEWSTATE=" & vstate & "&__VIEWSTATEGENERATOR=" & vstategen & "&__EVENTVALIDATION=" & eventval & "&ctl00$ddlTipoUsuario=#rdBtnNaoContribuinte" & "&ctl00$UserNameAcessivel=Digite+o+Usuário" & "&ctl00$PasswordAcessivel=x" & "&ctl00$ConteudoPagina$Login1$rblTipo=rdBtnNaoContribuinte" & "&ctl00$ConteudoPagina$Login1$UserName=MYUSERNAME" & "&ctl00$ConteudoPagina$Login1$Password=MYPASSWORD" & "&ctl00$ConteudoPagina$Login1$Login=Acessar" & "&ctl00$ConteudoPagina$Login1$txtCpfCnpj=Digite+o+Usuário"
Set xml2 = CreateObject("Msxml2.ServerXMLHTTP.6.0")
Set html2 = CreateObject("htmlFile")
With xml2
.Open "POST", "https://www.nfp.fazenda.sp.gov.br/Login.aspx", False
.setRequestHeader "Cookie", strCookie
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "Content-Lenght", Len(Postdata)
.send (Postdata)
End With
html2.body.innerhtml = xml2.responseText
Set objResult = html2.GetElementById("dadosDoUsuario")
GetElementById = objResult.innertext
MsgBox GetElementById
End Sub
It's possible but not that easy.
First you need to use CreateObject("Msxml2.ServerXMLHTTP.6.0") and not CreateObject("MSXML2.XMLHTTP").
Then follow these steps:
Open and send a GET to https://www.nfp.fazenda.sp.gov.br/login.aspx
Parse and store the cookie from the response header "Set-Cookie"
Parse and store the __VIEWSTATE, __VIEWSTATEGENERATOR, __EVENTVALIDATION from the HTML response
Build the data for the next query with the values parsed previously and with your user-name/password :
__EVENTTARGET:""
__EVENTARGUMENT:""
__VIEWSTATE:"..."
__VIEWSTATEGENERATOR:"..."
__EVENTVALIDATION:"..."
ctl00$ddlTipoUsuario:"#rdBtnNaoContribuinte"
ctl00$UserNameAcessivel:"Digite+o+Usuário"
ctl00$PasswordAcessivel:"x"
ctl00$ConteudoPagina$Login1$rblTipo:"rdBtnNaoContribuinte"
ctl00$ConteudoPagina$Login1$UserName:"..."
ctl00$ConteudoPagina$Login1$Password:"..."
ctl00$ConteudoPagina$Login1$Login:"Acessar"
ctl00$ConteudoPagina$Login1$txtCpfCnpj:"Digite+o+Usuário"
Open a POST to https://www.nfp.fazenda.sp.gov.br/login.aspx
Set the header "Cookie" with the cookie parsed at step 2
Set the header Content-Type: "application/x-www-form-urlencoded"
Set the header Content-Length with the length of the data
Send the POST with the data from step 4
Using VB and WinHTTP.WinHTTPrequest.5.1, I need to automate the download of a binary file for users that resides on a network share, requiring SSO authentication, without hardcoding or requiring a user to enter their password.
I have been reviewing solutions on the web for awhile now and the following VB is the closest I've gotten. I am having problems with the multiple redirects, which I am downloading instead of the file.
Public Sub download_SCData_test()
On Error GoTo err_me
Dim fData '() As Byte
Dim count As Long
Dim fileNum As Long
Dim ado_strm As Object
Dim winHTTP As New winHTTP.WinHttpRequest
Dim destPath As String
Dim destPath2 As String
Dim fileURL As String
Dim mainURL1 As String
Dim mainURL2 As String
' HttpRequest SetCredentials flags
' It might also be necessary to supply credentials to the proxy if you connect to the Internet through a proxy that requires authentication.
Const CREDENTIALS_FOR_SERVER = 0
Const CREDENTIALS_FOR_PROXY = 1
Const HTTPREQUEST_PROXYSETTING_PROXY = 2
mainURL1 = "http://wsso.someplace.on.the.web:XXXX/redirect.html?URL=https://someplace.on.the.web/quality/data_metrics/mac/"
mainURL2 = "http://wsso.someplace.on.the.web:XXXX/redirect.html?URL=https://someplace.on.the.web/quality/data_metrics/mac/"
'fileURL = "http://wsso.someplace.on.the.web:XXXX/redirect.html?URL=https://someplace.on.the.web/quality/data_metrics/mac/data.xlsb"
fileURL = "\\serverXXX\webdata\quality\data_metrics\mac\data.xlsb"
destPath = "C:\Temp\data.xlsb"
destPath2 = "C:\Temp\data2.xlsb"
With winHTTP
.SetProxy proxysetting:=HTTPREQUEST_PROXYSETTING_PROXY, ProxyServer:="wsso.someplace.on.the.web:XXXX", BypassList:="*.someplace.on.the.web"
.Option(Option:=WinHttpRequestOption_SslErrorIgnoreFlags) = 13056
.Option(Option:=WinHttpRequestOption_MaxAutomaticRedirects) = 20 'default 10
.Option(Option:=WinHttpRequestOption_EnableHttpsToHttpRedirects) = True
.Option(Option:=WinHttpRequestOption_EnableRedirects) = True
.Option(Option:=WinHttpRequestOption_RevertImpersonationOverSsl) = True
.SetTimeouts 30000, 30000, 30000, 30000 'ms - resolve, connect, send, receive
' Send a request to the server and wait for a response.
'POST authentication string to the main website address not to the direct file address
.Open Method:="POST", URL:=mainURL1, async:=False
'.SetCredentials UserName:="server\user", Password:="pass", Flags:=CREDENTIALS_FOR_SERVER ' this line has no effect
'strAuthenticate = "start-url=%2F&user=" & myuser & "&password=" & mypass & "&switch=Log+In"
.setRequestHeader Header:="Content-Type", Value:="application/x-www-form-urlencoded"
.setRequestHeader Header:="Date", Value:=Date
.send 'body:=strAuthenticate
If Not .WaitForResponse(TimeOut:=30000) Then MsgBox "timeout!": GoTo exit_me
Sleep 2000
.Open Method:="POST", URL:=mainURL2, async:=False
.send 'body:=strAuthenticate
If Not .WaitForResponse(TimeOut:=30000) Then MsgBox "timeout!": GoTo exit_me
Sleep 2000
.Open Method:="GET", URL:=fileURL, async:=True
.send
If Not .WaitForResponse(TimeOut:=30000) Then MsgBox "timeout!": GoTo exit_me
Sleep 2000
Do While InStr(1, .responseText, "function WSSORedirect()", vbTextCompare)
Sleep 2000
count = count + 1: If count > 2 Then Exit Do
Debug.Print InStr(1, .responseText, "function WSSORedirect()", vbTextCompare)
If InStr(1, .responseText, "function WSSORedirect()", vbTextCompare) < 1 Then MsgBox "any luck?"
.Open Method:="GET", URL:=fileURL, async:=True
.send
If Not .WaitForResponse(TimeOut:=30000) Then MsgBox "timeout!": GoTo exit_me
Debug.Print count
Sleep 2000
Loop
Sleep 2000
fData = .responseBody
' Display the results of the request.
Debug.Print "Credentials: "
Debug.Print .Status & " " & .StatusText
Debug.Print .getAllResponseHeaders
End With
If Dir(destPath) <> vbNullString Then Kill destPath
fileNum = FreeFile
Open destPath For Binary Access Write As #fileNum
Put #fileNum, 1, fData
Close #fileNum
If Dir(destPath2) <> vbNullString Then Kill destPath2
Set strm = CreateObject("ADODB.Stream")
With strm
.Type = 1
.Open
.Write winHTTP.responseBody
.SaveToFile destPath2, 2 'overwrite
End With
MsgBox "Completed. Check 'C:\Temp\'.", vbInformation, "execution completed"
exit_me:
On Error Resume Next
Set winHTTP = Nothing
Exit Sub
eerr_me:
Err.clear
Resume Next
End Sub
Response Headers
Credentials:
200 OK
Connection: Keep-Alive
Date: Sun, 21 Feb 2016 22:52:06 GMT
Keep-Alive: timeout=15, max=495
Content-Length: 1975
Content-Type: text/html
Last-Modified: Fri, 17 Aug 2012 17:01:12 GMT
Accept-Ranges: bytes
ETag: "XXXXXX-XXX-XXXXXXXXXXXXX"
Server: Apache/X.X.XX (Unix) mod_ssl/X.X.XX OpenSSL/X.X.XX XXX/X
Resultant download is still a WSSO redirect page not the file.
<html>
<head>
<script language="javascript" type="text/javascript">
WSSORedirect();
function WSSORedirect() {
var destinationURL = window.location.search;
if (destinationURL.substring(0, 5).toUpperCase() != "?URL=") {
destinationURL = "";
}
else {
destinationURL = destinationURL.substring(5, destinationURL.length);
}
if (destinationURL == "") {
document.writeln("redirect.html error - no URL. Usage: redirect.html?URL=[destination URL]");
document.close();
return;
}
location.replace(destinationURL);
}
</script>
</head>
</html>