通过 MS-Access 中的 VBA 进行 Google 搜索

Question

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

Answer 1

XMLHTTP (the client object) is not permitted to access remote objects (viruses) unless the scripting host is trusted. So the reason Access is given a permission error is because it hasn't told XMLHTTP that it has that permission.

I don't know more about XMLHTTP trust settings. See if the Trust Center (Access) helps.

Answer 2

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