I have coded these few lines below. The code correctly works when I connect through a VPN but no longer works outside VPN. The returned status code is 12007 out VPN and 200 with the VPN.
For example, you can use myUrl : "https://www.boursedirect.fr/fr/marche/euronext-paris/lyxor-ep-na-us-LU1832418856-MUA-EUR-XPAR/seance"
Do you have any idea how to resolve this difficulty?
Public Function InterrogationCours(myUrl) As Double
Dim avant as String, apres as String, cotation As String
avant = "quotation-last bd-streaming-select-value-last"
apres = "</span"
On Error Resume Next
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", myUrl, False
.Send
Debug.Print .Status
If .Status = 200 Then cotation = Split(Split(Split(.responseText, avant)(1), ">")(1), apres)(0)
End With
InterrogationCours = Nettoyage(cotation)
End Function
Related
The following snippet of code sends a XML request to the following site
Sub GetContents()
Dim XMLReq As New MSXML2.XMLHTTP60
XMLReq.Open "Get", "https://echa.europa.eu/brief-profile/-/briefprofile/100.028.723", False
XMLReq.send
End Sub
I have another Sub routine GetURL() which prints out the desired URL in this case: https://echa.europa.eu/brief-profile/-/briefprofile/100.028.723
How can I essentially concatenate the output of GetURL() into the BstrUrl? i.e.
XMLReq.Open "Get", "x", False where x is the output of GetURL()
Despite various attempts the syntax is not accepted as a URL.
Assuming you are combining from your earlier question then you need to ensure you write a function which returns the url (as Tim Williams has pointed out). I would expand upon this, in that I think you would need to consider adding a test to ensure both the request succeeded, there were results, and to pass the searchKeyWord as an argument to make your function more reusable. Along the same lines, you could pass the xmlhttp object into the function, so as to avoid continually creating and destroying them.
Avoid auto-instantiation, as you can get unexpected results, and Hungarian style notation. Personally, I also avoid those type characters, as they are harder to read.
vbNullString will offer faster assignment than = "".
I would also use a shorter, faster, and more reliable css pattern to retrieve the url, based on classes and a parent child relationship of two elements.
Public Sub GetContents()
Dim searchKeyWord As String, xmlReq As MSXML2.XMLHTTP60, html As MSHTML.HTMLDocument, url As String
searchKeyWord = "Acetone"
Set xmlReq = New MSXML2.XMLHTTP60
url = GetUrl(searchKeyWord, xmlReq)
Set html = New MSHTML.HTMLDocument
If url <> "N/A" Then
With xmlReq
.Open "GET", url, False
.send
If .Status = 200 Then
html.body.innerHTML = .responseText
Debug.Print html.querySelector("title").innerText
End If
End With
End If
End Sub
Public Function GetUrl(ByVal searchKeyWord As String, ByVal http As MSXML2.XMLHTTP60) As String
Const url = "https://echa.europa.eu/search-for-chemicals?p_auth=5ayUnMyz&p_p_id=disssimplesearch_WAR_disssearchportlet&p_p_lifecycle=1&p_p_state=normal&p_p_col_id=_118_INSTANCE_UFgbrDo05Elj__column-1&p_p_col_count=1&_disssimplesearch_WAR_disssearchportlet_javax.portlet.action=doSearchAction&_disssimplesearch_WAR_disssearchportlet_backURL=https%3A%2F%2Fecha.europa.eu%2Finformation-on-chemicals%3Fp_p_id%3Ddisssimplesearchhomepage_WAR_disssearchportlet%26p_p_lifecycle%3D0%26p_p_state%3Dnormal%26p_p_mode%3Dview%26p_p_col_id%3D_118_INSTANCE_UFgbrDo05Elj__column-1%26p_p_col_count%3D1%26_disssimplesearchhomepage_WAR_disssearchportlet_sessionCriteriaId%3D"
Dim html As MSHTML.HTMLDocument, dict As Object, i As Long, r As Long
Dim dictKey As Variant, payload$, ws As Worksheet
Set html = New MSHTML.HTMLDocument
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook.Worksheets("Sheet1")
dict("_disssimplesearchhomepage_WAR_disssearchportlet_formDate") = "1621017052777" 'timestamp
dict("_disssimplesearch_WAR_disssearchportlet_searchOccurred") = "true"
dict("_disssimplesearch_WAR_disssearchportlet_sskeywordKey") = searchKeyWord
dict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimer") = "true"
dict("_disssimplesearchhomepage_WAR_disssearchportlet_disclaimerCheckbox") = "on"
payload = vbNullString
For Each dictKey In dict
payload = IIf(Len(dictKey) = 0, WorksheetFunction.EncodeURL(dictKey) & "=" & WorksheetFunction.EncodeURL(dict(dictKey)), _
payload & "&" & WorksheetFunction.EncodeURL(dictKey) & "=" & WorksheetFunction.EncodeURL(dict(dictKey)))
Next dictKey
With http
.Open "POST", url, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/84.0.4147.135 Safari/537.36"
.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
.send (payload)
If .Status = 200 Then
html.body.innerHTML = .responseText
Else
GetUrl = "N/A"
Exit Function
End If
End With
Dim result As Boolean
result = html.querySelectorAll(".lfr-search-container .substanceNameLink").Length > 0
GetUrl = IIf(result, html.querySelector(".lfr-search-container .substanceNameLink").href, "N/A")
End Function
If GetURL is a function returning a string then this should work:
Sub GetContents()
Dim XMLReq As New MSXML2.XMLHTTP60
Dim url
url = GetURL()
XMLReq.Open "Get", url, False
XMLReq.send
End Sub
I want to change a URL to make it into the API compatible form.
If I have the string: "https://MYSERVER.com/browse/BIT-1234?jql=projectXXXXXX"
I want to change it into: "https://MYSERVER.com/rest/api/latest/search?jql=projectXXXXXX"
I use an InputBox to get the URL and I want to change it to that form and put it back into the script as shown below. How do I this?
Dim response As String
With CreateObject("Microsoft.XMLHTTP")
myURL= Application.InputBox("Enter the URL")
//CHANGE THE URL SOMEHOW
.Open "GET", myURL(changed URL goes here), False, **USERNAME**, **PASSWORD**
.send
response = .responseText
End With
Dim response As String, arr
myURL= Application.InputBox("Enter the URL")
arr = Split(myUrl, "?")
If ubound(arr) = 1 Then
With CreateObject("Microsoft.XMLHTTP")
myUrl = "https://MYSERVER.com/rest/api/latest/search?" & arr(1)
.Open "GET", myURL, False, **USERNAME**, **PASSWORD**
.send
response = .responseText
End With
Else
Msgbox "URL has no querystring!"
End If
I am attempting to update a SharePoint item via REST API, though I am receiving the below error:
{"odata.error":{"code":"-1, System.InvalidOperationException","message":{"lang":"en-US","value":"The type of data at position 0 is different than the one expected."}}}
I'm not quite sure what is causing this- I have the request type set to JSON, but it does not seem to accept my input. Any help is appreciated :-)
My code:
Sub Work_Damn_You()
Dim oXMLHTTP As Object
Dim sListNameOrGuid As String
Dim sBatchXml As String
Dim sSoapBody As String
Dim sWTF as string
Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
sListNameOrGuid = sListName
With oXMLHTTP
.Open "POST", "http://SPSITE.COM/_api/web/lists/GetByTitle('PAGE')/items(22)", True
.setRequestHeader "X-RequestDigest", testerino
.setRequestHeader "Accept", "application/json;odata=nometadata"
.setRequestHeader "Content-Type", "application/json;odata=verbose"
.setRequestHeader "__metadata", "(""type"":""SP.Data.QATrackerListItem"""
sWTF = """preTestComment""=""Hello"""
.send (sWTF)
Debug.Print (.responseText)
' Check response
If .Status = 200 Then
Debug.Print .Status & " [Happy Days!]"
Else
Debug.Print .Status & " [Sad Days :-(]"
End If
End With
Set oXMLHTTP = Nothing
End Sub
'''
I use XMLHTTP to connect to a API of a webserver and retrieve some data.
I connect to a http url so I can access from every position, but I want to do that when I am in office, if there is no internet connection, the macro is continuing to working connecting to a second url (internal IP).
I was thinking something like that:
Dim basic_url, basic_url_web, basic_url_local As String
basic_url_web = "www.notexistingurl.com"
basic_url_local = "192.168.178.3"
Dim myurl As String
On Error Resume Next
myurl = basic_url_web + "/api/product/read_product.php?id=4"
xmlhttp.Open "GET", myurl, False
xmlhttp.Send
If Err.Number <> 0 then
myurl = basic_url_local + "/api/product/read_product.php?id=4"
xmlhttp.Open "GET", myurl, False
xmlhttp.Send
END IF
On Error GoTo 0 'error checkin restored
But it is not working, actually when I call the xmlhttp.Send function I ever have a -2147467259 error number, and this is the same error number I have if actually there is no error.
If I don't use the "On Error Resume Next", then I have automation error on the .send() function (on an inexistent link), and therefore I cannot work with it.
I'm becoming crazy, I took about only 2-3 hours to do all the connection with the API and everything was working perfectly, but now I'm working since days to find a solution to have a second URL if the first cannot be reached.
Thank you for your suggestions
When I try to access common/example api url with vba (excel), there is no problem.
The required URL is as follows: "hppts://user:password#www.site.com/events/"
When I copy the url in web-browser there is no problem.
But when using VBA is returning an error: "Method of Open object IServerXMLHTTPRequest2 has failed"
Code:
Dim http As Object, str As Variant
Set http = CreateObject("MSXML2.XMLHTTP")
With http
.Open "GET", "https://user:password#www.site.com/events/", False
.send
str = .responseText
End With
x = UBound(str)