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
Related
I'm trying to download a xlsx file from a password protected website to use in PBI.
On PBI I already tried to use Power Query and the Web Connector. I also tried using Power Automate (online version with HTTP connector, since my desktop version doesn't run on background).
And finally I'm using VBA. But all of them returns a file with the website HTML code, instead of the data which should be in the xlsx.
The code from the last try with VBA (which I found here is bellow (with a generic website URL)):
Sub DownloadFile()
Dim evalURL As String
Dim streamObject As Object
Dim winHttpRequest As Object
Set winHttpRequest = CreateObject("Microsoft.XMLHTTP")
evalURL = "https://generic_website.com/Excel_file.xslx" '
winHttpRequest.Open "GET", evalURL, False, "username", "password"
winHttpRequest.send
If winHttpRequest.Status = 200 Then
Set streamObject = CreateObject("ADODB.Stream")
streamObject.Open
streamObject.Type = 1
streamObject.Write winHttpRequest.responseBody
streamObject.SaveToFile "C:\Users\MyUser\Downloads\Excel_file.xslx", 2 ' 1 = no overwrite, 2 = overwrite
streamObject.Close
End If
End Sub
If I log into the website and open the URL directly in a browser, it downloads the .xlsx file.
Is there any way to do that? I have no idea what's happening, since the same code worked to other people.
UPDATE:
I tried the VBA code bellow, and get the results you can see in the image here.
Sub Login()
Dim response As String
With CreateObject("Microsoft.XMLHTTP")
.Open "GET", "https://generic_website.com/Excel_file.xslx", False, "username", "password"
.send
response = .responseText
End With
MsgBox response
End Sub
I do not know if this works as I cant login, and dont know the file. hopefully it can point you in the right direction.
' VBA Editor->Tools->References
' find and select the following
' Microsoft WinHTTP Services,version 5.1
' Microsoft HTML Object Library
Sub GetFile()
Dim URL As String: URL = "your url"
Dim File As String: File = "your url/file.xslx"
Dim Email As String: Email = "your#address.com"
Dim Password As String: Password = "Your Password"
Dim Cookie As String
Dim Token As String
Dim Message As String
Dim HTML As HTMLDocument: Set HTML = New HTMLDocument
Dim HTTP As WinHttpRequest: Set HTTP = New WinHttpRequest
' you potentially need the csrf_token to post the login form.
' so we get the token, and any cookies sent
HTTP.Open "GET", URL, True
HTTP.Send
HTTP.WaitForResponse
HTML.body.innerHTML = HTTP.ResponseText
Cookie = HTTP.GetResponseHeader("Set-Cookie")
Token = HTML.getElementsByName("csrf_token")(0).Value
Message = "csrf_token=" & Token & "&email=" & URLEncode(Email) & "&senha=" & URLEncode(Password)
HTTP.Open "POST", URL, True
HTTP.SetRequestHeader "Content-type", "application/x-www-form-urlencoded"
HTTP.SetRequestHeader "Cookie", Cookie
HTTP.Send Message
HTTP.WaitForResponse
Cookie = HTTP.GetResponseHeader("Set-Cookie")
' i dont have credentials so dont know what happens after this point and cannot test any further
HTTP.Open "GET", File, True
HTTP.SetRequestHeader "Cookie", Cookie
HTTP.Send
HTTP.WaitForResponse
msgbox HTTP.responseText
' if the runtime error still occurs then not sure what to do
' however,
' if the above message box looks like HTML, it didnt work.
' if it doesn't, it MIGHT have worked, you just need to
' figure out how to save the data to a file
'Dim FileNumber As Integer: FileNumber = FreeFile()
'Open "C:\destination.xslx" For Binary Access Write As #FileNumber
'Put #FileNumber, 1, HTTP.ResponseBody
'Close #FileNumber
End Sub
'https://stackoverflow.com/a/218199/212869
Public Function URLEncode(StringVal As String) As String
Dim StringLen As Long: StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = "+"
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
I'm trying to get a number from a static page in a website, but when I do the HTML request, the result is a strange HTML without the informations of the original html that I want.
The website that I'm trying to get the information is:
https://fnet.bmfbovespa.com.br/fnet/publico/exibirDocumento?id=233361&cvm=true
but I can get the same result with:
https://fnet.bmfbovespa.com.br/fnet/publico/visualizarDocumento?id=233361&cvm=true
The number that I want to get is the number "0,05" in the page
My code is:
Sub trying()
Dim html As HTMLDocument
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://fnet.bmfbovespa.com.br/fnet/publico/exibirDocumento?id=233361&cvm=true&", False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT" 'to deal with potential caching
.send
html.body.innerHTML = .responseText
End With
Set element = html.getElementsByTagName("td")(31).innerText
Sheets("Sheet1").Cells(1, 1) = element
End Sub
I have also tried to do that using the InternetExplorer.Application but the the problem keeps the same
After trying a bunch of request headers, Accept request header is required to return the response in HTML:
Sub trying()
Dim html As HTMLDocument
Set html = New HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://fnet.bmfbovespa.com.br/fnet/publico/exibirDocumento?id=233361&cvm=true&", False
.setRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.9"
.send
html.body.innerHTML = .responseText
End With
Dim element As String
element = html.getElementsByTagName("td")(32).innerText
Sheets("Sheet1").Cells(1, 1) = element
End Sub
Just add a .htm (or .html) extension to the request to specify file type wanted.
Option Explicit
Public Sub trying()
Dim html As MSHTML.HTMLDocument
Set html = New MSHTML.HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://fnet.bmfbovespa.com.br/fnet/publico/exibirDocumento.htm?id=233361", False
.send
html.body.innerHTML = .responseText
End With
Debug.Print html.querySelector("tr:nth-child(6) .dado-valores").innerText
End Sub
Alternatives, that are a little more effort, include adding the accept header or base64 decoding the .responseText before writing to .innerHTML.
If you went down the less preferable base64 decode route, using function from here (note: pretty sure this is not the original source), then you will need to amend the following line:
.DataType = "bin.base64": .Text = Replace$(b64, Chr$(34), vbNullString) 'modified line
Public Function DecodeBase64(b64$)
Dim b
With CreateObject("Microsoft.XMLDOM").createElement("b64")
.DataType = "bin.base64": .Text = Replace$(b64, Chr$(34), vbNullString) 'modified line
b = .nodeTypedValue
With CreateObject("ADODB.Stream")
.Open: .Type = 1: .Write b: .Position = 0: .Type = 2: .Charset = "utf-8"
DecodeBase64 = .ReadText
.Close
End With
End With
End Function
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 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've created a vba script to parse the title of diffetent posts along with the editing status of those posts from a website. What I wish to do now is let my script parse the title from it's landing page but print the title at the same time when it will print the editing status. I do not wish to create two subs for this task. I do not even know if it is possible in vba. However, if anything unclear please check out the comment within my script.
Sub ImportTitleFromAnotherLocation()
Const LINK$ = "https://stackoverflow.com/questions/tagged/web-scraping"
Const prefix$ = "https://stackoverflow.com"
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim editInfo As Object, I&, targetUrl$, postTile$
With Http
.Open "GET", LINK, False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".summary .question-hyperlink")
For I = 0 To .Length - 1
postTitle = .item(I).innerText 'I like this line to be transferred to the location below
targetUrl = Replace(.item(I).getAttribute("href"), "about:", prefix)
With Http
.Open "GET", targetUrl, False
.send
Html.body.innerHTML = .responseText
End With
R = R + 1: Cells(R, 1) = postTitle 'here I wish to use the above line like this
Set editInfo = Html.querySelector(".user-action-time > a")
If Not editInfo Is Nothing Then
Cells(R, 2) = editInfo.innerText
End If
Next I
End With
End Sub
You are overwriting your html document in the loop. A simple way would be to use a second htmldocument variable. A more verbose way would be to store the titles before the loop, for example in an array during an additional loop, then use your i variable to index into that to retrieve each title during the existing loop.
Sub ImportTitleFromAnotherLocation()
Const LINK$ = "https://stackoverflow.com/questions/tagged/web-scraping"
Const prefix$ = "https://stackoverflow.com"
Dim Http As New XMLHTTP60, Html As New HTMLDocument, Html2 As New HTMLDocument
Dim editInfo As Object, I&, targetUrl$, postTile$
Dim postTitle As String, r As Long
With Http
.Open "GET", LINK, False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".summary .question-hyperlink")
For I = 0 To .Length - 1
postTitle = .item(I).innerText 'I like this line to be transferred to the location below
targetUrl = Replace$(.item(I).getAttribute("href"), "about:", prefix)
With Http
.Open "GET", targetUrl, False
.send
Html2.body.innerHTML = .responseText
End With
r = r + 1: ActiveSheet.Cells(r, 1) = postTitle 'here I wish to use the above line like this
Set editInfo = Html2.querySelector(".user-action-time > a")
If Not editInfo Is Nothing Then
ActiveSheet.Cells(r, 2) = editInfo.innerText
End If
Next I
End With
End Sub