Method to speed up vba scraping (POST request) - json

I have made a web scraper using vba and JSON Parser library.
My code is as below, and it works fine.
Sub Setcustoms()
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, returnshipvalue As String
Dim a, b As Variant
Dim mytext, finaltext As String
Dim myvalue As Object
Dim country() As String
Dim year As String
country = Split("NL,DE,MY,US,VN,UA,ID,JP,CN,CL,CA,TH,PL,RU,PH", ",")
'country = Split("MY,VN", ",")
Dim port() As String
port = Split("KRKAN,KRKUV,KRTSN,KRPUS,KRYMH,KRINC,KRPTK,KRKPO,KRKCN,KRBNP,KRUSN", ",")
'port = Split("KRKAN,KRKUV", ",")
Application.ScreenUpdating = False
i = 2
For Each a In country
For Each b In port
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", "https://www.bandtrass.or.kr/customs/total.do", False
.setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.66 Safari/537.36"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.setRequestHeader "Accept-Encoding", "gzip, deflate, br"
.send "SELECT_DIV1=PORT_DIV&GODS_TYPE=H&ECONO_TYPE=undefined&PORT_TYPE=B&LOCATION_TYPE=undefined&FILTER1_GODS_UNIT=&SELECT_DIV2=NATN_DIV&FILTER2_GODS_UNIT=&SELECT_DIV3=GODS_DIV&FILTER3_GODS_UNIT=10&POP_TABLE=&COL_NAME=&EXCEL_LOG=&MENU_CODE=CUS00301_POP&EXCEL_SUBJECT=&SelectCd3=4401310000" + _
"&SelectCd1=" & b & "&SelectCd2=" & a
mytext = Right(.responseText, Len(.responseText) - 44)
finaltext = Replace(Left(mytext, Len(mytext) - 2), "\", "")
Set JSON = JsonConverter.ParseJson(finaltext)
For Each myvalue In JSON
If Len(myvalue("BASE_DATE")) = 5 Then
year = myvalue("BASE_DATE")
Else
If myvalue("IM_WGHT") <> "" Then
Cells(i, 2).Value = DateSerial(CInt(Left(year, 4)), CInt(Left(LTrim(myvalue("BASE_DATE")), 2)) + 1, 0)
Cells(i, 3).Value = a
Cells(i, 4).Value = b
Cells(i, 5).Value = myvalue("IM_WGHT") / 1000
If myvalue("IM_WGHT") <> 0 Then
Cells(i, 6).Value = myvalue("IM_AMT") * 1000 / myvalue("IM_WGHT")
i = i + 1
Else
End If
Else
End If
End If
Next
End With
Next
Next
Application.ScreenUpdating = True
End Sub
The only issue I have is that the scraper takes about 10 minutes to finish.
I would really want to speed up the process since I will be updating the data on a monthly basis.
Another viable option is that I can scrape through the recent months, but in that case I have to rewrite the whole code.
Is there any possible method to speed up the process?
Thank you.

Related

Using Excel VBA, how to pull "a value from the HTML body" as well as "a cookie value" from a HTML response?

I want to extract the following items from a single website response to an Excel sheet:
Value of one of the cookies.
A value of an ID from the body of the response.
Cookie value to capture:
ID value to capture from HTML body:
I have searched for the solution, but I can find a way to pull a cookie separately with a different code and the id value separately from the HTML response body through another code.
However, combining the codes doesn't work as I need to use the same cookie value and the id value from the response in the subsequent post request.
To make the flow easier to understand, I will summarise my expectation below:
Visit "Site 1" grab the "Cookie" value and unique "ID" value from the response.
Pass the two values received in the previous response to the request of "Site 2".
Grab the link from the response of "Site 2" and visit "Site 3".
The code I have used to receive cookie values and HTML body content, which throws an error if uncommenting the codes to pull HTML body content. Kindly let me know where I am making a mistake or try a new way. (I have tried different way around, so I have kept them as comments.)
Sub Cookie_and_HTMLbody()
Dim strCookie As Variant
Dim strToken As Variant
Dim Doc As Object
Dim pontod As Object
'Dim Elements As IHTMLElementCollection
'Dim Element As IHTMLElement
On Error Resume Next
Set Doc = New HTMLDocument
With CreateObject("WinHttp.WinHttpRequest.5.1")
'With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://example.com", False
.setRequestHeader "Upgrade-Insecure-Requests", "1"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/90.0.4430.85 Safari/537.36"
.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"
.setRequestHeader "Sec-Fetch-Site", "none"
.setRequestHeader "Sec-Fetch-Mode", "navigate"
.setRequestHeader "Sec-Fetch-User", "?1"
.setRequestHeader "Sec-Fetch-Dest", "document"
.setRequestHeader "Accept-Encoding", "gzip, deflate"
.setRequestHeader "Accept-Language", "en-US,en;q=0.9"
.setRequestHeader "Connection", "close"
.send
Doc.body.innerHTML = .responseText
Set pontod = Doc.getElementById("trialrequestlanding").getElementsByTagName("div")(1).getElementsByTagName("div")(1).getElementsByTagName("div")(1).getElementsByTagName("div")(1).getElementsByTagName("form")(1).getElementsByTagName("div")(1).getElementsByTagName("input")(1)
strCookie = .getAllResponseHeaders
'strCookie = .getResponseHeader("Set-Cookie:")
'strCookie = Split(strCookie, "Set-Cookie:")
'strCookie = Trim(strCookie(UBound(strCookie)))
strCookie = Split(strCookie, vbCrLf)
strCookie = Trim(Split(Split(strCookie(5), ";")(0), ":")(1)) & "; " & Trim(Split(Split(strCookie(6), ";")(0), ":")(1))
MsgBox strCookie
'.responseType = document
'Doc = .responseText
strToken = pontod.getAttribute("value")
'strToken = Doc.querySelector("input[name='RequestVerificationToken']").getAttribute("value")
'strToken = document.getElementsByTagName("input")
'Set Doc = ie.document
MsgBox strToken
'Set Elements = .getElementsByTagName("input")
'For Each Element In Elements
' If Element.ID = "RequestVerificationToken" Then
'Range("c2").Value = Element.innerText
' MsgBox Element.Value
' End If
'Next Element
'Set Elements = Nothing
'Doc.Quit
'Set Doc = Nothing
End With
End Sub
Another code that works for retrieving a value from the HTML body is given below.
Sub Generate_Email()
Dim Shell As Object
Dim i As Variant
Dim bie As Object
Dim ie As Object
Dim Doc As HTMLDocument
Dim Elements As IHTMLElementCollection
Dim Element As IHTMLElement
'Set ie = New InternetExplorerMedium
Set ie = CreateObject("InternetExplorer.Application")
'Set ie = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
'Set ie = New InternetExplorer
ie.Visible = False
ie.navigate "https://randomsite.com/"
Do
DoEvents
Loop Until ie.readyState = 4
'Do While ie.Busy Or ie.readyState <> 4
'DoEvents
'Loop
Set Doc = ie.document
Set Elements = Doc.getElementsByTagName("span")
For Each Element In Elements
If Element.ID = "email_ch_text" Then
Range("c2").Value = Element.innerText
End If
Next Element
Set Elements = Nothing
ie.Visible = True
ie.Quit
Set ie = Nothing
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * From Win32_Process")
On Error Resume Next
For Each objItem In colItems
'msgbox objItem.name & " " & objItem.ProcessID & " " & objItem.CommandLine
If objItem.Name = "ielowutil.exe" Then objItem.Terminate
Next
For Each objItem In colItems
'msgbox objItem.name & " " & objItem.ProcessID & " " & objItem.CommandLine
If objItem.Name = "iexplore.exe" Then objItem.Terminate
Next
End Sub
How to retrieve both the values using a single code?
UPDATE (02 May 2021):
I have rewritten the code that supports extracting cookie properly but has an issue with pulling the element attribute "value", as shown in image 2.
Kindly help me to identify what mistake blocks me from extracting the element attribute in the below code.
Sub Test_Cookie_and_HTML()
Dim pontod As Object
Dim html As Object
On Error Resume Next
Set html = New HTMLDocument
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "https://portswigger.net/burp/pro/trial", False
.setRequestHeader "Upgrade-Insecure-Requests", "1"
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/90.0.4430.85 Safari/537.36"
.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"
.setRequestHeader "Sec-Fetch-Site", "none"
.setRequestHeader "Sec-Fetch-Mode", "navigate"
.setRequestHeader "Sec-Fetch-User", "?1"
.setRequestHeader "Sec-Fetch-Dest", "document"
.setRequestHeader "Accept-Encoding", "gzip, deflate"
.setRequestHeader "Accept-Language", "en-US,en;q=0.9"
.setRequestHeader "Connection", "close"
.send
html.body.innerHTML = .responseText
Dim strCookie As String
Dim sessionidCookie As String
strCookie = .getResponseHeader("Set-Cookie") ' --> "SESSIONID=40DD2DFCAF24A2D64544F55194FCE04E;path=/pamsservices;HttpOnly"
sessionidCookie = GetsessionIdCookie(strCookie) ' Strips to "SESSIONID=40DD2DFCAF24A2D64544F55194FCE04E"
MsgBox sessionidCookie
MsgBox RequestVerificationToken
End With
Set pontod = html.getElementById("trialrequestlanding").getElementsByTagName("input")(1)
MsgBox pontod.getAttribute("value")
End Sub

Automated search in google

I have over 20,000 searches I need to do in google. I want to use VBA to do an automate search in google or internet explorer and return link to excel. I have tried multiple VBA formulas and none of them seem to work. Is there a formula that will do an automate search and return link to the first site on google search to excel? Below is the formula I am currently using, but it isn't working. I am searching addresses in column A and need link to be return to column B.
Sub XMLHTTP_Count()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object
Dim start_time As Date
Dim end_time As Date
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim cookie As String
Dim result_cookie As String
start_time = Time
Debug.Print "start_time:" & start_time
For i = 2 To lastRow
url = "https://www.google.co.in/search?q=" & Cells(i, 1) & "&rnd=" & WorksheetFunction.RandBetween(1, 10000)
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.setRequestHeader "Content-Type", "text/xml"
XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
XMLHTTP.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.ResponseText
If html.getElementById("resultStats") Is Nothing Then
str_text = "0 Results"
Else
str_text = html.getElementById("resultStats").innerText
End If
Cells(i, 2) = str_text
DoEvents
Next
end_time = Time
Debug.Print "end_time:" & end_time
Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub
Well, you don't need the randomizer and it looks like the 'resultStats' changed to 'result-stats'. Try the code below and see if it does what you want.
Sub GetSearchStats()
Dim url As String, lastRow As Long
Dim XMLHTTP As Object, html As Object, objResultDiv As Object, objH3 As Object, link As Object
Dim start_time As Date
Dim end_time As Date
Dim var As String
Dim var1 As Object
lastRow = Range("A" & Rows.Count).End(xlUp).row
Dim cookie As String
Dim result_cookie As String
start_time = Time
Debug.Print "start_time:" & start_time
For i = 2 To lastRow
url = "https://www.google.com/search?q=" & Cells(i, 1)
Set XMLHTTP = CreateObject("MSXML2.serverXMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.setRequestHeader "Content-Type", "text/xml"
XMLHTTP.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; rv:25.0) Gecko/20100101 Firefox/25.0"
XMLHTTP.send
Set html = CreateObject("htmlfile")
html.body.innerHTML = XMLHTTP.ResponseText
Set objResultDiv = html.getElementById("rso")
Set var1 = html.getElementById("result-stats")
Cells(i, 2).Value = var1.innerText
DoEvents
Next
end_time = Time
Debug.Print "end_time:" & end_time
Debug.Print "done" & "Time taken : " & DateDiff("n", start_time, end_time)
MsgBox "done" & "Time taken : " & DateDiff("n", start_time, end_time)
End Sub
Result:
I think I answered your initial question. This sounds like a new question , and it probably warrants a new post, but I'll go ahead and offer a second answer here, to address this question.
Sub WebPage()
Dim internet As Object
Dim internetdata As Object
Dim div_result As Object
Dim header_links As Object
Dim link As Object
Dim URL As String
Set internet = CreateObject("InternetExplorer.Application")
internet.Visible = True
URL = "https://www.google.co.in/search?q=how+to+program+in+vba"
internet.Navigate URL
Do Until internet.ReadyState >= 4
DoEvents
Loop
Application.Wait Now + TimeSerial(0, 0, 5)
Set internetdata = internet.Document
Set div_result = internetdata.getelementbyid("res")
Set header_links = div_result.getelementsbytagname("h3")
For Each h In header_links
Set link = h.ChildNodes.Item(0)
Cells(Range("A" & Rows.Count).End(xlUp).Row + 1, 1) = link.href
Next
MsgBox "done"
End Sub
Result:
You can easily convert each text field to a hyperlink if you want to make thse all clickable links. Feel free to modify the code to suit your needs.

VBA - XML Web Log-In to USGA GHIN Website - Not Working

I have tried two VBA XML methods for logging on to the USGA Website, it seems straight forward, but neither works?! To test this, you will need your own GHIN Number and Last Name. Can someone please point out how I an screwing this up?
website = "https://www.ghin.com/login"
Sub Get_GHIN_Data()
Dim request As Object
Dim response As String
Dim html As New HTMLDocument
Dim website As String
Dim price As Variant
website = "https://www.ghin.com/login"
Set request = CreateObject("MSXML2.XMLHTTP")
request.Open "GET", website, False
'request.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
request.send
response = StrConv(request.responseBody, vbUnicode)
html.body.innerHTML = response
'********* Method 1 ************************************
'Dim oLogin As Object, oPassword As Object
'Set oLogin = .document.getElementsByName("ghinNumber")(0)
'Set oPassword = .document.getElementsByName("lastName")(0)
'oLogin.Value = ghinNumber 'real GHIN NUMBER
'oPassword.Value = LastName 'real Last Name
'html.document.forms(0).submit
'********* Method 2 ************************************
'html.getElementById("ghinNumber").Value = "ghinNumber" 'real GHIN NUMBER
'html.getElementById("lastName").Value = "Last name" 'real Last Name
'html.getElementClassName("btn fill cardinal").Click
'html.forms(0).submit
End Sub
Did you try this way? I think it will work.
Sub GetInformation()
Const Url = "https://api2.ghin.com/api/v1/public/login.json?"
Dim Http As New XMLHTTP60, ghinNum$, lastName$
ghinNum = "" 'put your ghinNum here
lastName = "" 'put your lastName here
With Http
.Open "GET", Url & "ghinNumber=" & ghinNum & "&lastName=" & lastName & "&remember_me=false", False
.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/80.0.3987.163 Safari/537.36"
.setRequestHeader "Referer", "https://www.ghin.com/login"
.send
End With
MsgBox Http.responseText
End Sub

Import Data in excel using JSON

I have developed a code to scrape data from a website but since I know very little about JSON I could be able to get the output as required shown in below snap:
However, I am getting all data from the web in the immediate window but want to organize these fields just like an above snap.
Here is my code:
Sub FetchTabularInfo()
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim col As Variant, icol As New Collection
Dim csrf As Variant, I&
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/home/statewise_ngo/76/35/1", False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".table tr a[onclick^='show_ngo_info']")
For I = 0 To .Length - 1
icol.Add Split(Split(.Item(I).getAttribute("onclick"), "(""")(1), """)")(0)
Next I
End With
For Each col In icol
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/ajaxcontroller/get_csrf", False
.send
csrf = .responseText
End With
csrf = Split(Replace(Split(csrf, ":")(1), """", ""), "}")(0)
With Http
.Open "POST", "https://ngodarpan.gov.in/index.php/ajaxcontroller/show_ngo_info", False
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send "id=" & col & "&csrf_test_name=" & csrf
End With
Debug.Print Http.responseText
Next col
End Sub
The output in the immediate window is:
The following shows you how to use a json parser. I use jsonconverter.bas. After copying the code from there into a standard module called JsonConverter, you need to go VBE>Tools>References>Add reference to Microsoft Scripting Runtime.
In the json response the {} are dictionaries accessed by key; the [] are collections accessed by index (or For Each over)
Option Explicit
Public Sub FetchTabularInfo()
Dim Http As New XMLHTTP60, Html As New HTMLDocument
Dim col As Variant, icol As New Collection
Dim csrf As Variant, i&
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/home/statewise_ngo/76/35/1", False
.send
Html.body.innerHTML = .responseText
End With
With Html.querySelectorAll(".table tr a[onclick^='show_ngo_info']")
For i = 0 To .Length - 1
icol.Add Split(Split(.item(i).getAttribute("onclick"), "(""")(1), """)")(0)
Next i
End With
Dim r As Long, headers(), results(), ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
headers = Array("SrNo", "Name of VGO/NGO", "Address", "City", "State", "Tel", "Mobile", "Web", "Email")
ReDim results(1 To icol.Count, 1 To UBound(headers) + 1)
For Each col In icol
r = r + 1
With Http
.Open "GET", "https://ngodarpan.gov.in/index.php/ajaxcontroller/get_csrf", False
.send
csrf = .responseText
End With
csrf = Split(Replace(Split(csrf, ":")(1), """", ""), "}")(0)
Dim json As Object
With Http
.Open "POST", "https://ngodarpan.gov.in/index.php/ajaxcontroller/show_ngo_info", False
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.send "id=" & col & "&csrf_test_name=" & csrf
Set json = JsonConverter.ParseJson(.responseText)
Dim orgName As String, address As String, srNo As Long, city As String
Dim state As String, tel As String, mobile As String, website As String, email As String
On Error Resume Next
orgName = json("registeration_info")(1)("nr_orgName")
address = json("registeration_info")(1)("nr_add")
city = json("registeration_info")(1)("nr_city")
srNo = r '<unsure where this is coming from.
state = Replace$(json("registeration_info")(1)("StateName"), "amp;", vbNullString)
tel = IIf(IsNull(json("infor")("0")("Off_phone1")), vbNullString, json("infor")("0")("Off_phone1")) '<unsure where this is coming from. Need a csrf to test with
mobile = json("infor")("0")("Mobile")
website = json("infor")("0")("ngo_url")
email = json("infor")("0")("Email")
On Error GoTo 0
Dim arr()
arr = Array(srNo, orgName, address, city, state, tel, mobile, website, email)
For i = LBound(headers) To UBound(headers)
results(r, i + 1) = arr(i)
Next
End With
Next col
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End Sub

How to download pdf from a hyperlink requiring login information in outlook by VBA

I use outlook to receive my emails(cannot change this...), I want to find a way in windows to automatically process one kind of my emails which have download links.
I want to find a way to selectively download files from the emails with key words.
The procedures I can think of to achieve this is:
search my emails with key words
find the hyperlink in the emails with the key words
download the files and save them in a folder.
My current code is :
Sub Search_Inbox()
Dim olFolder As Outlook.Folder
Dim myitems As Outlook.Items
Dim bodyString As String
Dim bodyStringLines
Dim splitLine
Dim hyperlink As String
Dim i As Integer
Dim found As Integer
Set olFolder = Application.GetNamespace("MAPI").Folders("lll#163.com").Folders("Inbox").Folders("abc")
Set myitems = olFolder.Items
i = 0
found = 0
'find the hyperlink in the emails"
For Each myitem In myitems
If InStr(1, myitem.Body, "passed", vbTextCompare) > 0 Then
If InStr(1, myitem.Body, "tested", vbTextCompare) > 0 Then
'inside the target email, search for the key word
bodyString = myitem.Body
bodyStringLines = Split(bodyString, vbCrLf)
For Each splitLine In bodyStringLines
i = i + 1
keyStart = InStr(splitLine, "keyword")
keyEnd = keyStart + Len("keyword") - 1
If found = 0 Then
If keyStart > 0 Then
If keyEnd = Len(splitLine) Then
found = 1
End If
End If
Else
hyperlink = splitLine
found = 0
Exit For
End If
Next
Debug.Print "hyperlink is"
Debug.Print hyperlink
'DownloadFile1 (hyperlink)
'DownloadFile2 (hyperlink)
End If
Else
Found = False
End If
Next
Set olFolder = Nothing
Set myitems = Nothing
End Sub
But I have a problem at the downloading part. The access to the hyperlink requires filling the login information. I tried the following two methods but failed...
Sub DownloadFile1(myURL As String)
Dim saveDirectoryPath As String
'*******************************
' Intitial setup
'*******************************
saveDirectoryPath = "C:\testfile.pdf" 'where your files will be stored
'*******************************
Dim fileNameArray() As String
Dim fileName As String
Dim arrayLength As Integer
Dim DateString As String
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
fileNameArray = Split(myURL, "/")
arrayLength = UBound(fileNameArray)
fileName = fileNameArray(arrayLength)
'Add date to the file incase there are duplicates comment out these lines if you do not want the date added
fileName = Replace(fileName, ".pdf", "_" & DateString & ".pdf")
fileName = Replace(fileName, ".PDF", "_" & DateString & ".PDF")
Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.Send
myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile saveDirectoryPath & fileName, 2 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
I failed (Access is denied) in line :
WinHttpReq.Send
I also tried the following code.
Sub DownloadFile2(myURL As String)
Dim strCookie As String, strResponse As String, _
strUrl As String
Dim xobj As Object
Dim WinHttpReq As Object
Set xobj = New WinHttp.WinHttpRequest
UN = "username"
PW = "password"
strUrl = "https://www.jedec.org/user/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 "C:\testfile.pdf", 1
oStream.Close
End If
End Sub
2018/03/01 problem (solved ): User-defined type not defined, at line:
Set xobj = New WinHttp.WinHttpRequest
Solved: Here is a trick that you should include the reference of Microsoft WinHTTP Service.
2018/03/02 problem (unsolved): The URL does not use a recognized protocol, at line:
xobj.Open "GET", strUrl, False
Anyone has any ideas about how to fix this?
reference for extracting information from email body:
https://www.datanumen.com/blogs/extract-show-hyperlink-addresses-email-via-outlook-vba/
http://www.vbaexpress.com/forum/showthread.php?49021-Download-File-from-Hyperlink-in-Body-of-Emailhttp://www.vbaexpress.com/forum/showthread.php?49021-Download-File-from-Hyperlink-in-Body-of-Email
reference for downloading file from hyperlink which requires login info. :
How to download a PDF that is in a hyperlink using VB in Outlook 2016
Vba download file from internet WinHttpReq with login not working