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
Related
url = https://www.justdial.com/Bangalore/Internet-Website-Developers/nct-11035713/page-1
Function getPageContent(ByVal url As String) As String
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
objHTTP.Open "GET", url, False
objHTTP.setRequestHeader "Content-Type", "text/xml"
objHTTP.setRequestHeader "Cache-Control", "no-cache"
objHTTP.setRequestHeader "Pragma", "no-cache"
objHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/84.0.4147.135 Safari/537.36"
objHTTP.send
If objHTTP.Status = 200 Then
getPageContent = objHTTP.responseText
End If
End Function
I am trying to extract justdial webpage but I am not getting the response, Instead i am getting 504 time out error. see my code for any corrections. I am getting response on postman
Please, adapt the function in this way (it needs MSXML2.XMLHTTP60). It needs a reference to 'Microsoft XML, v6.0' - (In VBE - Tools - References, scroll down, check it when found and press 'OK') :
Function getPageContent(ByVal url As String) As String
'It needs reference to 'Microsoft XML, v6.0'
Dim objHTTP As New MSXML2.XMLHTTP60
With objHTTP
.Open "GET", url, False
.setRequestHeader "Content-Type", "text/xml"
.setRequestHeader "Cache-Control", "no-cache"
.setRequestHeader "Pragma", "no-cache"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/84.0.4147.135 Safari/537.36"
.send
If .status = 200 Then
getPageContent = .responseText
End If
End With
End Function
Tested it in the next way:
Sub testExtractPage()
Dim url As String
url = "https://www.justdial.com/Bangalore/Internet-Website-Developers/nct-11035713/page-1"
Debug.Print getPageContent(url)'See the result in Immediate Window (Ctrl + G, in VBE)
End Sub
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
After I have parsed API results in Excel, I have trouble with unicode characters. There are lots of emoticons like smilies and hearts etc.
They appear like \ud83d\ude09\ud83d\ude09\ud83d\ude09\ud83d\ude09, but I want them to display like this: 😉😉😉😉
'this is my code
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
objHTTP.Open "Get", 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
''objHTTP.Response.contentType = "text/xml"
strResult = objHTTP.ResponseText
strResult = Replace(strResult, "\u0026", "&", 1)
strResult = Replace(strResult, "\u011f", "ğ", 1)
strResult = Replace(strResult, "\u011e", "Ğ", 1)
I have 4 different queries of IPR 1.2.3.4 (ip-reputation) to IBM's Xforce database, using basic authentication (base64 encoded), as well as URL-reputation. My version in python works great, printing out the appropriate JSON information:
...
if __name__ == '__main__':
apiKey = "1234...."
apiPwd = "5678..."
result = requests.get('https://xforce-api.mybluemix.net:443/ipr/1.2.3.4', verify=False,auth=(apiKey, apiPwd))
if result.status_code != 200:
print( "~ Bad Status Code: {}".format(result.status_code))
else:
print("~ The result is {}".format(result.status_code))
print("~ Rx Data={}".format(result._content))
The version in Go (using demisto's goxforce from github) works great. After setting my environment-variable key and password, I issue the commandline:
'xforceQuery -cmd ipr -q 1.2.3.4'
and it prints out the json information about 1.2.3.4, again, perfectly.
I use the browser-utility called 'Postman', specify basic authentication with my user/key and password, headers of Accept: application/json, Accept-Language: en, and Content-Type: application/json, and, again, it gives me the proper information (see .gif, below)
On the other hand, I try the same thing in VBA, and I get '401 Error: Not authorized'. What's wrong with this code?
Public Sub testXF()
Dim myKey As String
Dim myPass As String
myKey = "1234..."
myPass = "5678..."
pHtml = "xforce"
Dim ohttp As MSXML2.ServerXMLHTTP60
Set ohttp = New MSXML2.ServerXMLHTTP60
If timeout = 0 Then timeout = 60
ohttp.Open "GET", "https://xforce-api.mybluemix.net:443/ipr/1.2.3.4", False, myKey, myPass
With ohttp
.SetRequestHeader "Content-Type", "application/json"
.SetRequestHeader "Accept", "application/json"
.SetRequestHeader "Accept-Language", "en"
.SetTimeouts 0, 30 * 1000, 30 * 1000, timeout * 1000
.SetRequestHeader "Authorization", "Basic " + _
Base64Encode(myKey + ":" + myPass)
.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
End With
ohttp.Send ("")
With ohttp
pStatus = .status
pText = .ResponseText
pResponseHeaders = .GetAllResponseHeaders()
End With
Debug.Print "GET", pStatus, pText
Set ohttp = Nothing
End Sub
I used this code for my Macro in VBA in excel:
Sub Macro1()
Dim URL As String, JSONString As String, objHTTP As Object
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "xxxxx"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
JSONString = "{""name"": ""long"",""startDate"": 12345,""endDate"": 67890,""status"": ""in progress""}"
objHTTP.send JSONString
Debug.Print objHTTP.Status
Debug.Print objHTTP.responseText
End Sub
In the immediate window, I received this error:
400 Apache Tomcat/8.0.28 - Error
reportH1
{font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;font-size:22px;}
H2
{font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;font-size:16px;}
H3
{font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;font-size:14px;}
BODY
{font-family:Tahoma,Arial,sans-serif;color:black;background-color:white;}
B
{font-family:Tahoma,Arial,sans-serif;color:white;background-color:#525D76;} P
{font-family:Tahoma,Arial,sans-serif;background:white;color:black;font-size:12px;}A
{color : black;}A.name {color : black;}.line {height: 1px;
background-color: #525D76; border: none;}
HTTP Status 400 - Required String parameter 'name' is
not presenttype Status
reportmessage Required String parameter 'name' is not
presentdescription The request sent by the client
was syntactica lly incorrect.Apache
Tomcat/8.0.28
I have not known how to solve it, please help me !
I solved this problem:
Sub Macro1()
Dim URL As String, JSONString As String, objHTTP As Object
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
URL = "xxxxx?name=long&startDate=12345&endDate=67890&status=in progress"
objHTTP.Open "POST", URL, False
objHTTP.setRequestHeader "Content-type", "application/x-www-form-urlencoded"
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send
Debug.Print objHTTP.Status
Debug.Print objHTTP.responseText
End Sub