following code-snippet searches with google search for company-names. this code is working in excel:
Dim el As Object
Dim http As Object
Dim html As New HTMLDocument
Dim lng_row_start As Long
Dim lng_row As Long
Dim lng_row_new As Long
Dim int_column_name As Integer
Dim int_column_news As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
'------------
str_sheet = "news"
lng_row_start = 3
int_column_name = 1
int_column_news = 3
'------------
lng_row = lng_row_start
lng_row_new = lng_row_start
Do While 0 < Len(Sheets(str_sheet).Cells(lng_row, int_column_name).Value)
str_google = Replace(Sheets(str_sheet).Cells(lng_row, int_column_name).Value, " ", "+")
http.Open "GET", "https://www.google.com/search?q=" & str_google & "&tbm=nws", False
http.send
html.body.innerHTML = http.responseText
'--------
Set el = html.getElementById("rso")
now i want to do that in access. using XMLHTTP gives me "no permission"-error on the "http.send"-line. using ServerXMLHTTP gives me a responseText saying that i got the "error 403. client has no permission to get url".
now i added this line for the ServerXMLHTTP:
http.setRequestHeader "User-Agent", "Mozilla/4.0+(compatible;+MSIE+7.0;+Windows+NT+5.1)"
now i get an responseText saying something about "signing in/login". im german so it tells me "Anmelden".
so i still cant get the google-search result.
some ideas? maybe how i get a correct requestHeader so i dont get the "login" responseText?
i use ms-access 2007-20016.
following is my access code snippet:
On Error GoTo err_stan
'DEFINITION
Dim str_google As String
Dim el2 As New HTMLDocument
Dim el3 As New HTMLDocument
Dim el4 As New HTMLDocument
Dim el As New HTMLDocument
Dim http As Object
Dim html As New HTMLDocument
Dim db As DAO.Database
Dim rs_companies As DAO.Recordset
Dim rs_news As DAO.Recordset
'DECLARATION
Set db = CurrentDb
Set rs_companies = db.OpenRecordset("SELECT DISTINCT companyName FROM qGoogleSearch")
Set rs_news = db.OpenRecordset("SELECT * FROM Tnews")
'Set http = CreateObject("MSXML2.XMLHTTP.6.0")
Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
'ALGORITHM
rs_companies.MoveFirst
Do While Not rs_companies.EOF
str_google = "https://www.google.com/search?q=" & _
Replace(rs_companies.Fields("companyName").Value, " ", "+") & _
"&tbm=nws"
'http.SetOption 2, 13056
http.Open "GET", str_google, False
'http.setRequestHeader "User-Agent", "Mozilla/4.0+(compatible;+MSIE+7.0;+Windows+NT+5.1)"
http.send
html.body.innerHTML = http.responseText
Set el = html.getElementById("rso")
EDIT: using this url works: https://www.google.com/search?q=bango+plc
this does give a permission error: https://www.google.com/search?q=bango+plc&tbm=nws in excel it works fine...
why does XMLHTTP work in excel but not in access? i tried to put the msaccess-file in a trusted location. did not work
Update try this and report back:
This is what works for me:
Set FSO = CreateObject("Scripting.FileSystemObject")
' How To Write To A File
Set File = FSO.CreateTextFile("C:\Foobar.html",True)
File.Write cstr(http("GET", "https://www.google.com/search?q=bango+plc&tbm=nws", "text/html; charset=UTF-8", "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", ""))
File.Close
Set FSO = Nothing
Set File = Nothing
call MsgBox(http("GET", "https://www.google.com/search?q=bango+plc&tbm=nws", "text/html; charset=UTF-8", "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", ""))
''MsgBox(httpGet("https://localhost:5001/api/departments?pageNumber=1&pageSize=1", "application/xml; charset=UTF-8", "application/xml"))
Sub httpGet(sUrl, sRequestHeaderContentType, sRequestHeaderAccept)
Call http("GET", sUrl, sRequestHeaderContentType, sRequestHeaderAccept, "")
End Sub
''MsgBox(httpPost("https://localhost:5001/api/departments?userfriendlyName=987Junk", "application/xml; charset=UTF-8", "application/xml", ""))
Sub httpPost(sUrl,sRequestHeaderContentType, sRequestHeaderAccept, sbody)
Call http("POST", sRequestHeaderContentType, sRequestHeaderAccept, sbody)
End Sub
Function http(httpCommand, sUrl, sRequestHeaderContentType, sRequestHeaderAccept, sbody)
Err.Clear
Dim oXML 'AS XMLHTTP60
'Set oXML = CreateObject("msxml2.XMLHTTP.6.0")
Set oXML = CreateObject("Msxml2.ServerXMLHTTP.6.0")
Dim aErr
On Error Resume Next
Call oXML.Open(CStr(httpCommand), CStr(sUrl), False)
'oXML.setRequestHeader "User-Agent", "Mozilla/4.0"
oXML.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/89.0.4389.114 Safari/537.36"
'oXML.setRequestHeader "Authorization", "Basic base64encodeduserandpassword"
oXML.setRequestHeader "Content-Type", CStr(sRequestHeaderContentType)
'oXML.setRequestHeader "Content-Type", "text/xml"
oXML.setRequestHeader "CharSet", "charset=UTF-8"
'oXML.setRequestHeader "Accept", "*/*"
oXML.setRequestHeader "Accept", CStr(sRequestHeaderAccept)
oXML.setRequestHeader "cache-control", "no-cache"
oXML.setRequestHeader "sec-ch-ua","Google Chrome;v=89, Chromium;v=89, ;Not A Brand;v=99"
aErr = Array(Err.Number, Err.Description)
On Error Goto 0
If 0 = aErr(0) Then
On Error Resume Next
Call oXML.send(sbody)
aErr = Array(Err.Number, Err.Description)
On Error Goto 0
Select Case True
Case 0 <> aErr(0)
Trace("send failed: " & CStr(aErr(0)) & " " & CStr(aErr(1)))
Case 200 = oXML.status
'Trace(sUrl & " HttpStatusCode:" & oXML.status & " HttpStatusText:" & oXML.statusText)
http = oXML.responseText
Case 201 = oXML.status
Trace(sUrl & " HttpStatusCode:" & oXML.status & " HttpStatusText:" & oXML.statusText)
Case Else
Trace("further work needed:")
Trace("URL:" & CStr(sUrl) & " Message Status:" & CStr(oXML.status) & " Message Text:" & CStr(oXML.statusText))
Trace("further work needed:")
End Select
Else
Trace("open failed: " & CStr(aErr(0)) & " " & CStr(aErr(1)))
End If
'httpPost.HttpStatusCode = cstr(oXML.status)
'httpPost.HttpStatusText = cstr(oXML.statusText)
'httpPost.responseText = cstr(oXML.responseText)
Set oXML = Nothing
End Function
Function Trace(Message1)
MsgBox(Message1)
End Function