How to GET response using VBA?
This code here does not work. In Debug.Pring() or MsgBox is empty.
TargetURL = snURL + selectedMail
Set HTTPReq = CreateObject("WinHttp.WinHttpRequest.5.1")
HTTPReq.Open "GET", TargetURL, False
HTTPReq.SetCredentials snUser, snPass, 0
HTTPReq.setRequestHeader "Accept", "application/json"
Debug.Print HTTPReq.responseText
I want to get JSON data.
Optional libraries (needed, if early binding is used, in general the code will work without them):
Change the companyName variable:
Sub TestMe()
Dim xmlObject As Object
Dim companyName As String: companyName = "Google"
Dim strUrl As String
strUrl = "http://dev.markitondemand.com/MODApis/Api/v2/Lookup/json?input=" & companyName
Set xmlObject = CreateObject("MSXML2.XMLHTTP")
With xmlObject
.Open "GET", strUrl, False
.Send
End With
Dim response As String
response = "{""data"":" & xmlObject.ResponseText & "}"
Debug.Print response
End Sub
Related
I am trying to download a macro enabled file (xlsm) from Jira, I have tried the below method and able to download the file but the file is corrupted. Please advice what I am missing here.
Dim myURL As String
myURL = "Put your download link here"
Dim HttpReq As Object
Set HttpReq = CreateObject("Microsoft.XMLHTTP")
HttpReq.Open "GET", myURL, False, "username", "password"
HttpReq.send
myURL = HttpReq.responseBody
If HttpReq.Status = 200 Then
Set oStrm = CreateObject("ADODB.Stream")
oStrm.Open
oStrm.Type = 1
oStrm.Write HttpReq.responseBody
oStrm.SaveToFile ThisWorkbook.Path & "\" & "file.xlsm", 2 ' 1 = no overwrite, 2 = overwrite
oStrm.Close
End If
(source)
Finally after several attempts, below code work, hope this is helpful for others.
Private Sub DownloadFromJira()
Dim oJiraService As MSXML2.ServerXMLHTTP60
Dim sPath As String
Dim sStatus As String
Dim FileData() As Byte
Dim FileNum As Long
Set oJiraService = New MSXML2.ServerXMLHTTP60
sPath = "C:\Users\**ID**\Downloads\Test.xlsm"
With oJiraService
.Open "GET", "https://**MyJiraLink**/secure/attachment/123455/Test.xlsm", False
.setRequestHeader "Content-Type", "application/json"
.setRequestHeader "Authorization", "Basic " & EncodeBase64(JiraUID & ":" & JiraPWD)
.setRequestHeader "Accept", "application/json"
.send
sStatus = .status & " | " & .statusText
If .status = "401" Then
MsgBox "Not Connected"
End If
FileData = .responseBody
FileNum = FreeFile
Open sPath For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
End With
Set oJiraService = Nothing
End Sub
Private Function EncodeBase64(srcTxt As String) As String
Dim arrData() As Byte
arrData = StrConv(srcTxt, vbFromUnicode)
Dim objXML As MSXML2.DOMDocument60
Dim objNode As MSXML2.IXMLDOMElement
Set objXML = New MSXML2.DOMDocument60
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
EncodeBase64 = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function
Below code is where I get 401 Unautorized access error After 2nd request Rest API is called .
Here is the developer Rest API documentation supplied.
https://simplybook.me/en/api/developer-api/tab/rest_api#method_GET_/admin/bookings/{id}
Sub Test()
Dim objRequest As Object
Dim loginResponse As Object
Dim strUrl As String
Dim bookingcode As String
Dim blnAsync As Boolean
Dim strloginResponse, strBookingresponse, strlogoutresponse, strparameter As String
Dim scriptControl As Object
Set scriptControl = CreateObject("MSScriptControl.ScriptControl")
scriptControl.Language = "JScript"
Set objRequest = CreateObject("MSXML2.XMLHTTP")
'strUrl = "https://user-api.simplybook.me/admin/auth"
strUrl = "https://user-api-v2.simplybook.me/admin/auth"
blnAsync = True
'strUrl = "https://user-api.simplybook.me/admin/auth"
strUrl = "https://user-api-v2.simplybook.me/admin/auth"
With objRequest
.Open "POST", strUrl, blnAsync
.SetRequestHeader "Content-Type", "application/json"
.Send ("{""company"":""simplydemo"",""login"":""admin"",""password"":""demo""}")
'spin wheels whilst waiting for response
While objRequest.readyState <> 4
DoEvents
Wend
strloginResponse = .responsetext
End With
Set loginResponse = scriptControl.Eval("(" + strloginResponse + ")")
Debug.Print loginResponse.token
Debug.Print loginResponse.company
Debug.Print loginResponse.login
Debug.Print loginResponse.refresh_token
Debug.Print loginResponse.domain
Debug.Print loginResponse.require2fa
Debug.Print loginResponse.allowed2fa_providers
Debug.Print loginResponse.auth_session_id
bookingcode = "0bz29vl4t"
strUrl = "https://user-api-v2.simplybook.me/admin/bookings/" & bookingcode
'strUrl = "https://user-api.simplybook.me/admin/bookings/" & bookingcode
strparameter = "(""{""X-Company-Login"":""" & loginResponse.company & """,""X-Token"":""" & loginResponse.token & """}"")"
Debug.Print strparameter
Set objRequest = CreateObject("MSXML2.XMLHTTP")
With objRequest
.Open "GET", strUrl, blnAsync
.SetRequestHeader "Content-Type", "application/json"
.Send strparameter
'spin wheels whilst waiting for response
While objRequest.readyState <> 4
DoEvents
Wend
strBookingresponse = .responsetext
End With
Debug.Print strBookingresponse
Set objRequest = CreateObject("MSXML2.XMLHTTP")
strUrl = "https://user-api-v2.simplybook.me/admin/auth/logout"
strparameter = "(""{""auth_token"":""" & loginResponse.token & """}"")"
With objRequest
.Open "POST", strUrl, blnAsync
.SetRequestHeader "Content-Type", "application/json"
.Send strparameter
'spin wheels whilst waiting for response
While objRequest.readyState <> 4
DoEvents
Wend
strlogoutresponse = .responsetext
End With
Debug.Print strBookingresponse
Set scriptControl = Nothing
Set objRequest = Nothing
Set loginResponse = Nothing
End Sub
Below response is i get for the Debug.print statements:
4eb8b7f6ce820c24e66a754557635ede02e6e808ce27e311511a20bef4ed44e3
simplydemo
admin
b60ee1e89264ee5e856583fc20e63926e71a25bded9f9a540d12d5ccbf51bf51
simplybook.me
False
("{"X-Company-Login":"simplydemo","X-Token":"4eb8b7f6ce820c24e66a754557635ede02e6e808ce27e311511a20bef4ed44e3"}")
{"code":401,"message":"Unauthorized","data":[],"message_data":[]}
{"code":401,"message":"Unauthorized","data":[],"message_data":[]}
I am working on a procedure, in MS-Access VBA, to POST an XML text string to a web service and process the XML text string that is returned from the service.
The issue I am having is that the responseText property is always empty when it should contain a XML text string. No errors are returned and the .status = "OK".
I have tried the WinHttp.WinHttpRequest, MSXML2.XMLHTTP, and MSXML2.ServerXMLHTTP objects and consistently have the same issue.
Here is a code example:
Public Function Send() As Boolean
Dim oXHR As MSXML2.XMLHTTP60
Dim sURL, sCred As String
Dim sRequest, sResult, sStatus, sHeader As String
Dim bRtn As Boolean
BuildReqXML
sRequest = Me.RequestXML_String
With orsValues
sURL = .Fields("WebServiceURL").Value
sCred = Base64Encode(Trim(.Fields("User").Value) & ":" & Trim(.Fields("Password").Value))
End With
Set oXHR = New MSXML2.XMLHTTP60
With oXHR
.Open "POST", sURL, False
.SetRequestHeader "Authorization", "Basic " & sCred & """"
.SetRequestHeader "User-Agent", "Mozilla/4.0"
.SetRequestHeader "Content-Type", "text/xml"
.Send sRequest
sStatus = .StatusText
sResult = .ResponseText
sHeader = .GetAllResponseHeaders
If sResult <> "" Then
If Contains(sResult, "<") Then ReadXML sResult, "Response"
Debug.Print sResult
Else
Debug.Print sHeader
Debug.Print sRequest
End If
End With
Set oXHR = Nothing
End Function
I have verified that the web service is working correctly by building a similar call in a HTML document, sending the XML string, and receiving the response XML string.
Can someone please help me fix my issue?
I found the problem, with help from Fiddler.
The line setting the authorization header
.SetRequestHeader "Authorization", "Basic " & sCred & """"
Was adding a (") to the header line. The corrected line is
.SetRequestHeader "Authorization", "Basic " & sCred
Thank you for your help
I'm trying to upload an image to a REST webpage. I can do this successfully though a cURL call:
curl -u Admin:admin -T C:\temp\wikiTable.jpg http://192.168.0.35:8080/xwiki/rest/wikis/xwiki/spaces/Main/pages/WebHome/attachments/table.jpg
I'm now trying to achieve this though a HTTP Post in Excel vba but experiencing some problems. I'm currently doing this:
Const STR_BOUNDARY As String = "---------------------------123456789abc"
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
Dim sFileName As String
Dim sUrl As String
sFileName = "C:\temp\wikiTable.jpg"
sUrl = "http://192.168.0.35:8080/xwiki/rest/wikis/xwiki/spaces/Main/pages/WebHome/attachments/table.jpg"
'--- read file
nFile = FreeFile
Open sFileName For Binary Access Read As nFile
If LOF(nFile) > 0 Then
ReDim baBuffer(0 To LOF(nFile) - 1) As Byte
Get nFile, , baBuffer
sPostData = StrConv(baBuffer, vbUnicode)
End If
Close nFile
'-- post
Dim HTTPReq As Object
Set HTTPReq = CreateObject("WinHttp.WinHttpRequest.5.1")
HTTPReq.Option(4) = 13056
HTTPReq.Open "Post", sUrl, False
HTTPReq.SetCredentials "Admin", "admin", 0
HTTPReq.setRequestHeader "Content-Type: multipart/form-data;"
HTTPReq.send sPostData
MsgBox (HTTPReq.responseText)
For the responseText I keep getting the following error:
10.4.6 405 Method Not Allowed
The method specified in the Request-Line is not allowed for the resource
identified by the Request-URI. The response MUST include an Allow header
containing a list of valid methods for the requested resource.
https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html#sec10.4.6
Any ideas what I'm doing wrong here?
The following worked in the end:
Private Function PostFile(sUrl As String, sFileName As String, strUserName As String, strPassword As String) As String
Dim nFile As Integer
Dim baBuffer() As Byte
Dim sPostData As String
'--- read file
Dim adoStream
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Mode = 3 ' read write
adoStream.Type = 1 ' adTypeBinary
adoStream.Open
adoStream.LoadFromFile (sFileName)
adoStream.Position = 0
'--- post
Dim HTTPReq As Object
Set HTTPReq = CreateObject("WinHttp.WinHttpRequest.5.1")
HTTPReq.Option(4) = 13056
HTTPReq.Open "PUT", sUrl, False
HTTPReq.setRequestHeader "Authorization", "Basic " + Base64Encode(strUserName + ":" + strPassword)
HTTPReq.setRequestHeader "Content-Type", "multipart/form-data"
HTTPReq.setRequestHeader "Content-Length", adoStream.Size
HTTPReq.send (adoStream.Read(adoStream.Size))
pvPostFile = HTTPReq.responseText
Set adoStream = Nothing
End Function
I advise you try to call the method "POST" instead of "Post" because it might be case sensitive.
The code below only scrapes/parses one page of data (50 results) into excel however, I would like it to scrape multiple pages (500 results) - please help. (Base64Encode was taken from a different source - I don't take credit for it)
`Function GetData() As Boolean
Application.ScreenUpdating = False
Dim objHTTP As New MSXML2.XMLHTTP
Dim strURL As String
Dim strUserName As String
Dim strPassword As String
Sheet1.Range("A2:R2000") = ""
Sheet1.Activate
strUserName = "User"
strPassword = "Password"
For i = 1 To UBound(MyArray)
strURL = "https://.ngx.com/ngxcs/indexPrice.xml"
objHTTP.Open "GET", strURL, False
objHTTP.setRequestHeader "Authorization", "Basic " & Base64Encode(strUserName & ":" & strPassword)
objHTTP.setRequestHeader "Host", "secure.example.com"
objHTTP.setRequestHeader "Content-Type", "text"
objHTTP.send "Nothing"
While objHTTP.readyState <> 4
DoEvents
Wend
Dim strResponseReceived As String
strResponseReceived = objHTTP.responseText
Debug.Print objHTTP.responseText
MsgBox strResponseReceived
Dim xDoc As DOMDocument
Set xDoc = New DOMDocument
xDoc.LoadXML objHTTP.responseText`
''''''''''''''''''''''''''''''''''''''''''
Rest of Code that outputs it into excel
Thanks for the Help!