I'm going to have multiple instrument numbers and URLs to run this code through. The instrument numbers will start in Column B from Row 8 and down. This VBA currently only runs instrument number 19930074944. How can I have it loop through all these instrument numbers and skip blank cells?
searchResultsURL = baseURL & "GetRecDataDetail.aspx?rec=19930074944&suf=&bdt=1/1/1947&edt=11/18/2016&nm=&doc1=&doc2=&doc3=&doc4=&doc5="
So I need to edit it so that it's:
searchResultsURL = baseURL & "GetRecDataDetail.aspx?rec= & InstNum & "&suf=&bdt=1/1/1947&edt=11/18/2016&nm=&doc1=&doc2=&doc3=&doc4=&doc5="
Then InstNum has to reference B8 and down. And run all this code on each different URL. I have no idea how to do that. Thanks so much!
Option Explicit
Public Sub Download_PDF()
Dim baseURL As String, searchResultsURL As String, pdfURL As String, PDFdownloadURL As String
Dim httpReq As Object
Dim HTMLdoc As Object
Dim PDFlink As Object
Dim cookie As String
Dim downloadFolder As String, localFile As String
Const WinHttpRequestOption_EnableRedirects = 6
'Folder in which the downloaded file will be saved
downloadFolder = ThisWorkbook.Path
If Right(downloadFolder, 1) <> "\" Then downloadFolder = downloadFolder & "\"
baseURL = "http://recorder.maricopa.gov/recdocdata/"
searchResultsURL = baseURL & "GetRecDataDetail.aspx? rec=19930074944&suf=&bdt=1/1/1947&edt=11/18/2016&nm=&doc1=&doc2=&doc3=&doc4=&doc5="
Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
With httpReq
'Send GET to request search results page
.Open "GET", searchResultsURL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:46.0) Gecko/20100101 Firefox/46.0"
.Send
cookie = .getResponseHeader("Set-Cookie")
'Put response in HTMLDocument for parsing
Set HTMLdoc = CreateObject("HTMLfile")
HTMLdoc.body.innerHTML = .responseText
'Get PDF URL from pages link
'< a id="ctl00_ContentPlaceHolder1_lnkPages" title="Click to view unofficial document"
' href="unofficialpdfdocs.aspx?rec=19930074944&pg=1&cls=RecorderDocuments&suf=" target="_blank">11< /a>
Set PDFlink = HTMLdoc.getElementById("ctl00_ContentPlaceHolder1_lnkPages")
pdfURL = Replace(PDFlink.href, "about:", baseURL)
'Send GET request to the PDF URL with automatic http redirects disabled. This returns a http 302 status (Found) with the Location header containing the URL of the PDF file
.Open "GET", pdfURL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:46.0) Gecko/20100101 Firefox/46.0"
.setRequestHeader "Referer", searchResultsURL
.setRequestHeader "Set-Cookie", cookie
.Option(WinHttpRequestOption_EnableRedirects) = False
.Send
PDFdownloadURL = .getResponseHeader("Location")
'Send GET to request the PDF file download
.Open "GET", PDFdownloadURL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:47.0) Gecko/20100101 Firefox/46.0"
.setRequestHeader "Referer", pdfURL
.Send
End With
End Sub
Something like this:
Sub DoAll()
Dim c As Range
Set c = Activesheet.Range("B8")
Do While c.Value<>""
Download_PDF c.Value
Set c = c.offset(1,0) 'next value
Loop
End sub
Edit your original code to include a parameter (relevant parts shown only)
Public Sub Download_PDF(InsNumber)
'....
'....
searchResultsURL = baseURL & "GetRecDataDetail.aspx?rec=" & InsNumber & _
"&suf=&bdt=1/1/1947&edt=11/18/2016&nm=&doc1=&doc2=&doc3=&doc4=&doc5="
'....
'....
End Sub
Hi The below code should work for you..Looping through all the elements..
Note: change sheet1 to required sheet.Pls mark as answer.
Option Explicit
Public Sub Download_PDF()
Dim baseURL As String, searchResultsURL As String, pdfURL As String, PDFdownloadURL As String
Dim httpReq As Object
Dim HTMLdoc As Object
Dim PDFlink As Object
Dim cookie As String
Dim downloadFolder As String, localFile As String
Const WinHttpRequestOption_EnableRedirects = 6
'Folder in which the downloaded file will be saved
downloadFolder = ThisWorkbook.Path
If Right(downloadFolder, 1) <> "\" Then downloadFolder = downloadFolder & "\"
baseURL = "http://recorder.maricopa.gov/recdocdata/"
Set httpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
Dim Instnum As String
Dim i As Integer
For i = 8 To Sheet1.Range("b" & Rows.Count).End(xlUp).Row
Instnum = Sheet1.Cells(i, 2).Value
searchResultsURL = baseURL & "GetRecDataDetail.aspx? rec=" & Instnum & "&suf=&bdt=1/1/1947&edt=11/18/2016&nm=&doc1=&doc2=&doc3=&doc4=&doc5="
With httpReq
'Send GET to request search results page
.Open "GET", searchResultsURL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:46.0) Gecko/20100101 Firefox/46.0"
.Send
cookie = .getResponseHeader("Set-Cookie")
'Put response in HTMLDocument for parsing
Set HTMLdoc = CreateObject("HTMLfile")
HTMLdoc.body.innerHTML = .responseText
'Get PDF URL from pages link
'< a id="ctl00_ContentPlaceHolder1_lnkPages" title="Click to view unofficial document"
' href="unofficialpdfdocs.aspx?rec=19930074944&pg=1&cls=RecorderDocuments&suf=" target="_blank">11< /a>
Set PDFlink = HTMLdoc.getElementById("ctl00_ContentPlaceHolder1_lnkPages")
pdfURL = Replace(PDFlink.href, "about:", baseURL)
'Send GET request to the PDF URL with automatic http redirects disabled. This returns a http 302 status (Found) with the Location header containing the URL of the PDF file
.Open "GET", pdfURL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:46.0) Gecko/20100101 Firefox/46.0"
.setRequestHeader "Referer", searchResultsURL
.setRequestHeader "Set-Cookie", cookie
.Option(WinHttpRequestOption_EnableRedirects) = False
.Send
PDFdownloadURL = .getResponseHeader("Location")
'Send GET to request the PDF file download
.Open "GET", PDFdownloadURL, False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64; rv:47.0) Gecko/20100101 Firefox/46.0"
.setRequestHeader "Referer", pdfURL
.Send
End With
Next i
End Sub
Related
I am working on xmlHTTP request to extract JSON data from the web.
The below is my code.
Public Sub testlibor2()
Dim JSON As Object
Dim ws As Worksheet, results(), i As Long, s As String
Dim BL As String
Dim mypara As String
Dim mydest As String
Dim URL, URL1, URL2, URL3 As String
URL1 = "draw=1&columns%5B0%5D%5Bdata%5D=0&columns%5B0%5D%5Bname%5D=wdt_ID&columns%5B0%5D%5Bsearchable%5D=true&columns%5B0%5D%5Borderable%5D=true&columns%5B0%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B0%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B1%5D%5Bdata%5D=1&columns%5B1%5D%5Bname%5D=date&columns%5B1%5D%5Bsearchable%5D=true&columns%5B1%5D%5Borderable%5D=true&columns%5B1%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B1%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B2%5D%5Bdata%5D=2&columns%5B2%5D%5Bname%5D=weekday&columns%5B2%5D%5Bsearchable%5D=true&columns%5B2%5D%"
URL2 = "5Borderable%5D=true&columns%5B2%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B2%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B3%5D%5Bdata%5D=3&columns%5B3%5D%5Bname%5D=o&columns%5B3%5D%5Bsearchable%5D=true&columns%5B3%5D%5Borderable%5D=true&columns%5B3%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B3%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B4%5D%5Bdata%5D=4&columns%5B4%5D%5Bname%5D=wdt_column&columns%5B4%5D%5Bsearchable%5D=true&columns%5B4%5D%5Borderable%5D=true&columns%5B4%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B4%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B5%5D%5Bdata%5D=5&columns%5B5%5D%5Bname%5D=wdt_column_1&columns%5B5%5D%5Bsearchable%5D=true&columns%5B5%5D%5Borderable%5D=true&columns%5B5%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B5%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B6%5D%5Bdata%5D=6&columns%5B6%5D%5Bname%5D=1m&columns%5B6%5D%5Bsearchable%"
URL3 = "5D=true&columns%5B6%5D%5Borderable%5D=true&columns%5B6%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B6%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B7%5D%5Bdata%5D=7&columns%5B7%5D%5Bname%5D=wdt_column_2&columns%5B7%5D%5Bsearchable%5D=true&columns%5B7%5D%5Borderable%5D=true&columns%5B7%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B7%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B8%5D%5Bdata%5D=8&columns%5B8%5D%5Bname%5D=3m&columns%5B8%5D%5Bsearchable%5D=true&columns%5B8%5D%5Borderable%5D=true&columns%5B8%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B8%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B9%5D%5Bdata%5D=9&columns%5B9%5D%5Bname%5D=wdt_column_3&columns%5B9%5D%5Bsearchable%5D=true&columns%5B9%5D%5Borderable%5D=true&columns%5B9%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B9%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B10%5D%5Bdata%5D=10&columns%"
URL4 = "5B10%5D%5Bname%5D=wdt_column_4&columns%5B10%5D%5Bsearchable%5D=true&columns%5B10%5D%5Borderable%5D=true&columns%5B10%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B10%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B11%5D%5Bdata%5D=11&columns%5B11%5D%5Bname%5D=6m&columns%5B11%5D%5Bsearchable%5D=true&columns%5B11%5D%5Borderable%5D=true&columns%5B11%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B11%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B12%5D%5Bdata%5D=12&columns%5B12%5D%5Bname%5D=wdt_column_5&columns%5B12%5D%5Bsearchable%5D=true&columns%5B12%5D%5Borderable%5D=true&columns%5B12%5D%5Bsearch%5D%5Bvalue%5D=&columns%5B12%5D%5Bsearch%5D%5Bregex%5D=false&columns%5B13%5D%5Bdata%5D=13&columns%5B13%5D%5Bname%5D=wdt_column_6&columns%5B13%5D%5Bsearchable%5D=true&columns%5B13%5D%5Borderable%5D=true&columns%5B13%5D%5Bsearch%5D%5Bvalue%5D=&column"
mypara = URL1 & URL2 & URL3 & URL4
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://iborate.com/wp-admin/admin-ajax.php?action=get_wdtable&table_id=12", False
.setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.88 Safari/537.36"
.send mypara
Debug.Print .responseText
Set JSON = JsonConverter.ParseJson(.responseText)
End With
End Sub
The code above does not work at all. I cannot receive any JSON data from this.
I have adjusted all the request Headers based on the details from the Chrome dev Tools, and I have
absolutely no Idea what the issue is.
The original URL is as below. I am trying to access the table in the web.
http://iborate.com/usd-libor/
Thank you!
One additional question. Are there any alternatives to dealing with URL strings that are too long to be contained inside one variable? I divided the string as below but I am not sure if this is the best way to handle it.
UPDATE
Based on #QHarr's idea I have changed the Form data into a JSON string. However the code still does not work.
Public Sub testlibor2()
Dim JSON As Object
Dim ws As Worksheet, results(), i As Long, s As String
Dim shipvalue As String, custom As String, MyURL As String
Dim BL As String
Dim mypara, newpara As String
Dim URL, URL1, URL2, URL3, URL4, URL5 As String
URL1 = "{""draw"":""2"",""columns[0][data]"":""0"",""columns[0][name]"":""wdt_ID"",""columns[0][searchable]"":""true"",""columns[0][orderable]"":""true"",""columns[0][search][value]"":"""",""columns[0][search][regex]"": ""false"",""columns[1][data]"": ""1"",""columns[1][name]"": ""date"",""columns[1][searchable]"": ""true"",""columns[1][orderable]"": ""true"",""columns[1][search][value]"": ""|"",""columns[1][search][regex]"": ""false"",""columns[2][data]"": ""2"",""columns[2][name]"": ""weekday"",""columns[2][searchable]"": ""true"",""columns[2][orderable]"":""true"",""columns[2][search][value]"": """","
URL2 = """columns[2][search][regex]"":""false"",""columns[3][data]"":""3"",""columns[3][name]"": ""o"",""columns[3][searchable]"": ""true"",""columns[3][orderable]"": ""true"",""columns[3][search][value]"": """",""columns[3][search][regex]"": ""false"",""columns[4][data]"": ""4"",""columns[4][name]"": ""wdt_column"",""columns[4][searchable]"": ""true"",""columns[4][orderable]"": ""true"",""columns[4][search][value]"": """",""columns[4][search][regex]"": ""false"",""columns[5][data]"": ""5"",""columns[5][name]"": ""wdt_column_1"",""columns[5][searchable]"": ""true"",""columns[5][orderable]"": ""true"",""columns[5][search][value]"": """",""columns[5][search][regex]"": ""false"",""columns[6][data]"": ""6"",""columns[6][name]"": ""1m"",""columns[6][searchable]"": ""true"",""columns[6][orderable]"": ""true"",""columns[6][search][value]"": """",""columns[6][search][regex]"": ""false"",""columns[7][data]"": ""7"",""columns[7][name]"": ""wdt_column_2"",""columns[7][searchable]"": ""true"","
URL3 = """columns[7][orderable]"": ""true"",""columns[7][search][value]"": """",""columns[7][search][regex]"": ""false"",""columns[8][data]"": ""8"",""columns[8][name]"": ""3m"",""columns[8][searchable]"": ""true"",""columns[8][orderable]"": ""true"",""columns[8][search][value]"": """",""columns[8][search][regex]"": ""false"",""columns[9][data]"": ""9"",""columns[9][name]"": ""wdt_column_3"",""columns[9][searchable]"": ""true"",""columns[9][orderable]"": ""true"",""columns[9][search][value]"": """",""columns[9][search][regex]"": ""false"",""columns[10][data]"": ""10"",""columns[10][name]"": ""wdt_column_4"",""columns[10][searchable]"": ""true"",""columns[10][orderable]"": ""true"",""columns[10][search][value]"": """",""columns[10][search][regex]"": ""false"",""columns[11][data]"": ""11"",""columns[11][name]"": ""6m"",""columns[11][searchable]"": ""true"",""columns[11][orderable]"": ""true"",""columns[11][search][value]"": """",""columns[11][search][regex]"": ""false"","
URL4 = """columns[12][data]"": ""12"",""columns[12][name]"": ""wdt_column_5"",""columns[12][searchable]"": ""true"",""columns[12][orderable]"": ""true"",""columns[12][search][value]"": """",""columns[12][search][regex]"": ""false"",""columns[13][data]"": ""13"",""columns[13][name]"": ""wdt_column_6"",""columns[13][searchable]"": ""true"",""columns[13][orderable]"": ""true"",""columns[13][search][value]"": """",""columns[13][search][regex]"": ""false"",""columns[14][data]"": ""14"",""columns[14][name]"": ""wdt_column_7"",""columns[14][searchable]"": ""true"",""columns[14][orderable]"": ""true"",""columns[14][search][value]"": """",""columns[14][search][regex]"": ""false"",""columns[15][data]"": ""15"",""columns[15][name]"": ""wdt_column_8"",""columns[15][searchable]"": ""true"",""columns[15][orderable]"": ""true"",""columns[15][search][value]"": """",""columns[15][search][regex]"": ""false"",""columns[16][data]"": ""16"",""columns[16][name]"": ""wdt_column_9"",""columns[16][searchable]"": ""true"","
URL5 = """columns[16][orderable]"": ""true"",""columns[16][search][value]"": """",""columns[16][search][regex]"": ""false"",""columns[17][data]"": ""17"",""columns[17][name]"": ""12m"",""columns[17][searchable]"": ""true"",""columns[17][orderable]"": ""true"",""columns[17][search][value]"": """",""columns[17][search][regex]"": ""false"",""order[0][column]"": ""1"",""order[0][dir]"": ""desc"",""start"": ""0"",""length"": ""10"",""search[value]"": """",""search[regex]"": ""false"",""wdtNonce"": ""ce62a523fa"",""sRangeSeparator"": ""|""}"
mypara = URL1 & URL2 & URL3 & URL4 & URL5
newpara = Replace(mypara, " ", "")
Debug.Print newpara
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "http://iborate.com/wp-admin/admin-ajax.php?action=get_wdtable&table_id=12", False
.setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.88 Safari/537.36"
.setRequestHeader "Accept-Encoding", "gzip, deflate"
.send newpara
Debug.Print .responseText
Set JSON = JsonConverter.ParseJson(.responseText)
End With
End Sub
I have checked couple of times to make sure the JSON string is exactly identical as the one suggested below from QHarr.
Can anyone identify a solution from here?
i have tried using google translate to translate names from language to another using c# and its working fine but now im trying to do the same thing using ms access vba i have tried so many ways but with no luck!
this is the code written in c# and its working fine
public string trans_arabic_to_english(string word)
{
var toLanguage = "en";//English
var fromLanguage = "ar";//Deutsch
var url = $"https://translate.googleapis.com/translate_a/single?client=gtx&sl={fromLanguage}&tl={toLanguage}&dt=t&q={HttpUtility.UrlEncode(word)}";
var webClient = new WebClient
{
Encoding = System.Text.Encoding.UTF8
};
var result = webClient.DownloadString(url);
try
{
result = result.Substring(4, result.IndexOf("\"", 4, StringComparison.Ordinal) - 4);
return result;
}
catch
{
return "Error";
}
}
this is the code in vba
Private Sub Command0_Click()
Dim toLan As String, fromLan As String, resp As String, s As String, a_name As String, url As String
toLang = "ar"
fromlang = "en"
a_name = "omar khalil"
url = "https://translate.googleapis.com/translate_a/single?"
url = url & "client=gtx&sl={""" & toLang & """}&tl={""" & fromlang & """}&dt=t&q={""" & a_name & """}"
url = "https://translate.googleapis.com/translate_a/single?client=gtx&sl="
url = url & fromlang & "&tl=" & to_lang & "&dt=t&q=" & a_name
'==
Dim ob As Object
Set ob = CreateObject("WinHttp.WinHttpRequest.5.1")
ob.Open "POST", url, False
ob.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
ob.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
ob.Send
If ob.Status <> 200 Then
resp = ob.ResponseText
MsgBox resp
End Sub
i have tried using WinHttp also with no luck at all!
any one can help me with this issue Thanks .
Try the next function, please:
Private Function GTranslate(strInput As String, strFromLang As String, strToLang As String) As String
Dim strURL As String, objHTTP As Object, objHTML As Object, objDivs As Object, objDiv As Variant
strURL = "https://translate.google.com/m?hl=" & strFromLang & _
"&sl=" & strFromLang & _
"&tl=" & strToLang & _
"&ie=UTF-8&prev=_m&q=" & strInput
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
objHTTP.Open "GET", strURL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.Send ""
Set objHTML = CreateObject("htmlfile")
With objHTML
.Open
.Write objHTTP.responseText
.Close
End With
Set objDivs = objHTML.getElementsByTagName("div")
For Each objDiv In objDivs
'If objDiv.className = "t0" Then 'it does not work, anymore
If objDiv.className = "result-container" Then 'adapted on December 28th
GTranslate = objDiv.innerText: Exit For
End If
Next objDiv
Set objHTML = Nothing: Set objHTTP = Nothing
End Function
It can be called in the next way:
Sub testTranslateG()
MsgBox GTranslate("Este es un libro", "auto", "en")
End Sub
The second parameter can be "auto" (like in the testing Sub), or the specific language abbreviation if more accurate translation needed ("es" - Spanish, "ru" - Russian, "ro" - Romanian etc.).
In order to find the correct abbreviation, you can open Google Translate page, right click and choose 'View page source'. Then try finding some language. Let us say Spanish. In that area you will see a script having strings like the following one: "code:'it',name:'Italian'". Easy to understand that "it" is the abbreviation for Italian...
I'm trying to download a file from this website, tried a bunch of code i can find and the file is downloaded but shows the html of the login page
Below are 2 versions that I tried. I tried every code snippet I could find on SO and have had no luck so far.
I tried both versions here, they had the same problem but their solution isn't working for me.
Vba download file from internet WinHttpReq with login not working
It seems like I'm not getting past the login process. I know that the variables (username, password) are wrong in the code below, but I did try every variable I can find in the source (UniqueUser, UniqueLogin, LoginName, every word they had there) and still no luck.
Some versions of the code error on the SET COOKIE line, others give no errors, the file is downloaded but it's still the html of the login page inside the file
Sub DownloadFile2(myURL As String)
Dim CurPath As String
CurPath = CurrentProject.Path & "\"
Dim strCookie As String, strResponse As String, _
strUrl As String
Dim xobj As Object
Dim WinHttpReq As Object
Set xobj = New WinHttp.WinHttpRequest
UN = "hhhhh"
PW = "gggg"
strUrl = "https://pnds.health.ny.gov/login"
xobj.Open "POST", strUrl, False
xobj.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
xobj.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
xobj.Send "username=" & UN & "&password=" & PW & "&login=login"
strResponse = xobj.ResponseText
strUrl = myURL
xobj.Open "GET", strUrl, False
xobj.SetRequestHeader "Connection", "keep-alive"
xobj.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
xobj.Send
strCookie = xobj.GetResponseHeader("Set-Cookie")
strResponse = xobj.ResponseBody
If xobj.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write xobj.ResponseBody
oStream.SaveToFile CurPath & "ValidationDataHFIS.csv", 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
Sub ddd()
DownloadFile2 ("https://pnds.health.ny.gov/xxxx/xxxx/8")
End Sub
You are sending login details to an incorrect login address. Your correct login address is https://pnds.health.ny.gov/account/login the page expects LoginName and Token. The token is generated using SecurityManager.generate( u, p );
You can still consult with their IT Team to make sure you are not violating their policy.
Here is a way of doing it using a IE browser object.
Private Sub DownloadValidationData()
'Create Internet explorer object
Dim IE As Object
Set IE = CreateObject("INTERNETEXPLORER.APPLICATION")
IE.Visible = True
Dim URL As String: URL = "https://pnds.health.ny.gov/account/login"
IE.Navigate URL
While IE.READYSTATE <> READYSTATE_COMPLETE
DoEvents
Wend
Dim userName As String: userName = "test"
Dim password As String: password = "test"
'Fill the login form
IE.Document.getElementById("UniqueUser").Value = userName
IE.Document.getElementById("UniquePass").Value = password
'Submit the form
IE.Document.querySelector("button.SignIn").Click
'Wait for login to complete
While IE.READYSTATE <> READYSTATE_COMPLETE
DoEvents
Wend
'Verify you are logged in: As we don't know what the site looks like after login in. Only you can do this step.
'Navigate to Download Page. This should prompt to save the file.
IE.Navigate theDownloadUrl '"https://pnds.health.ny.gov/xxxx/xxxx/8"
'Once downloaded just close the browser and exit
'IE.Quit
'Set IE = Nothing
'If you are interested in geting/generating the token using their script you can play around with below lines. These lines come before loging in. Please note: execScript is depreciated now
'Dim Token as string
'IE.Document.parentwindow.execScript ("$('#Token').val(SecurityManager.generate(""" & username & """, """ & password & """ ))")
'Token = IE.Document.getElementById("Token").Value
'Use the token to sign in using your code. That'll be xobj.Send "LoginName =" & userName & "&Token=" & Token
'But not sure if it will work.
End Sub
I would make a little recursive function that checks for redirects until there are none left.
Like this:
Option Explicit
Const WinHttpRequestOption_EnableRedirects = 6
Public Function GetRedirect(ByRef oHttp As Object, ByVal strUrl As String) As String
With oHttp
.Open "HEAD", strUrl, False
.Send
End With
If oHttp.Status = 301 Or oHttp.Status = 302 Or oHttp.Status = 303 Then
GetRedirect= GetRedirect(oHttp, oHttp.GetResponseHeader("Location"))
Else
GetRedirect= strUrl
End If
End Function
Sub DownloadFile2(myURL As String)
Dim CurrentProject
Dim CurPath As String
CurPath = CurrentProject.Path & "\"
Dim strCookie As String, strResponse As String, _
strUrl As String
Dim xobj As Object
Dim WinHttpReq As Object
Set xobj = CreateObject("WINHTTP.WinHTTPRequest.5.1")
Dim UN As String
UN = "hhhhh"
Dim PW As String
PW = "gggg"
strUrl = "https://pnds.health.ny.gov/login"
With xobj
.Open "POST", strUrl, False
.SetRequestHeader "Connection", "keep-alive"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.Send "&username=" & UN & "&password=" & PW & "&login=login"
End With
strUrl = GetRedirect(xobj, myURL)
If xobj.Status = 200 Then
Dim oStream As Object
Set oStream = CreateObject("ADODB.Stream")
With oStream
.Open
.Type = 1
.Write xobj.ResponseBody
.SaveToFile CurPath & "ValidationDataHFIS.csv", 2 ' 1 = no overwrite, 2 = overwrite
.Close
End With
End If
End Sub
Sub ddd()
DownloadFile2 ("https://pnds.health.ny.gov/xxxx/xxxx/8")
End Sub
NOTE: This code is untested and would need to be adapted for your use case.
I have some problem with this vba code. This work from over the year. After last execution i get error in ".Write objHTTP.responseBody --runtime error 3001" I try figure out solution but I don't have any ideas. The code login in on page and download 4 files.
This is POST information:
Answers headers (250 B)
Connection
Keep-Alive
Content-Disposition
attachement; filename="baza.csv";
Content-Type
application/csv
Date
Tue, 17 Jul 2018 13:58:32 GMT
Keep-Alive
timeout=5, max=300
Server
Apache/2.4.25
Transfer-Encoding
chunked
Request Headers (976 B)
Accept
text/html,application/xhtml+xm…plication/xml;q=0.9,*/*;q=0.8
Accept-Encoding
gzip, deflate, br
Accept-Language
pl,en-US;q=0.7,en;q=0.3
Connection
keep-alive
Content-Length 38
Content-Type
application/x-www-form-urlencoded
Cookie _pk_id.50.777d=00d79034e23a5b6…41fc349c56e551787285709412976
DNT 1
Host listarobinsonow.pl
Referer https://listarobinsonow.pl/userpanel/base
Upgrade-Insecure-Requests 1
User-Agent Mozilla/5.0 (Windows NT 10.0; …) Gecko/20100101 Firefox/61.0
Code:
Sub SMB_DownloadAll()
Dim destfolder As String
destfolder = ActiveWorkbook.Path
' Autoryzacja
' Dim objHTTP As New WinHttp.WinHttpRequest
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "http://www.listarobinsonow.pl/auth/login"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
objHTTP.send ("identity=xxxxxx&password=xxxxxxx")
objHTTP.WaitForResponse
' pobranie 4 plików
SMB_Download objHTTP, "post", destfolder
SMB_Download objHTTP, "mail", destfolder
SMB_Download objHTTP, "tele", destfolder
SMB_Download objHTTP, "smss", destfolder
ThisWorkbook.Save
End Sub
Sub SMB_Download(ByRef objHTTP, base_type As String, destfolder As String)
URL = "http://www.listarobinsonow.pl/userpanel/base"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
objHTTP.send ("base_type=" + base_type + "&form_type=base_download")
objHTTP.WaitForResponse
' Dim oStream1 As New ADODB.Stream
Set oStream1 = CreateObject("ADODB.Stream")
With oStream1
.Type = 1
.Open
.Write objHTTP.responseBody - the place where i get error run time 3001
.SaveToFile destfolder + "\" + base_type + ".csv", 2
End With
End Sub
I've written a code to fetch the name
of a restaurant using its phone number applying
"GET" http method but what i'm doing wrong
with this process is beyond my knowledge. So, if anybody extends a helping
hand to resolve this issue, i would be very grateful to him.
Thanks in advance.
Sub test()
Dim xmlhttp As New MSXML2.XMLHTTP60, myHtml As New HTMLDocument
Dim PostData As String, ele As Object, thing As Object
Dim x As Long
x = 2
PostData = "what=5197365924"
xmlhttp.Open "GET", "http://mobile.canada411.ca/search/" & PostData, False
xmlhttp.setRequestHeader "Content-Type", "text/xml"
xmlhttp.send
myHtml.body.innerHTML = xmlhttp.responseText
Set ele = myHtml.getElementsByClassName("merchant-title__name jsShowCTA")
For Each thing In ele
Cells(x, 1) = thing.innertext
x = x + 1
Next thing
End Sub
Your code is pretty fine, but your endpoint does not show anything, you can test in your browser and you will see.
I suggest you read the YellowAPI doc and test this kind of endpoint, changing the values YOUR_API_KEY_HERE and YOUR_UID_HERE.
Lots of issues were there in my post. However, I've fixed it already. Now, it is good to go.
Sub reverse_search()
Dim http As New XMLHTTP60, html As New HTMLDocument
Dim ArgumentString As String, post As Object
ArgumentString = "what=5197365924&where=Canada&redirect=reversetobusiness"
With http
.Open "GET", "https://www.yellowpages.ca/bus/Ontario/Amherstburg/Downtown-Expresso-Cafe/522901.html?" & ArgumentString, False
.setRequestHeader "Content-Type", "text/xml"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/60.0.3112.113 Safari/537.36"
.send
html.body.innerHTML = .responseText
End With
For Each post In html.getElementsByClassName("merchant-title__name")
x = x + 1: Cells(x, 1) = post.innerText
Next post
End Sub