通過 MS-Access 中的 VBA 進行 Google 搜索

Question

以下代碼片段搜索與谷歌搜索公司名稱。 此代碼在 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")

現在我想在訪問中做到這一點。 使用 XMLHTTP 在“http.send”行上給了我“沒有權限”-錯誤。 使用 ServerXMLHTTP 給我一個 responseText 說我得到了“錯誤 403。客戶端無權獲取 url”。

現在我為 ServerXMLHTTP 添加了這一行：

http.setRequestHeader "User-Agent", "Mozilla/4.0+(compatible;+MSIE+7.0;+Windows+NT+5.1)"

現在我得到一個 responseText 說一些關於“登錄/登錄”的內容。 我是德國人，所以它告訴我“Anmelden”。

所以我仍然無法獲得谷歌搜索結果。

一些想法？ 也許我如何獲得正確的 requestHeader 所以我沒有得到“登錄”響應文本？

我使用 ms-access 2007-20016。

以下是我的訪問代碼片段：

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")

編輯：使用這個 url 作品： https://www.google.com/search?q=bango+plc

這確實給出了權限錯誤： excel 中的 https://www.google.com/search?q=bango+plc&tbm=nws它工作正常...

為什么 XMLHTTP 可以在 excel 中工作，但不能在訪問中工作？ 我試圖將 msaccess 文件放在受信任的位置。 不工作

Answer 1

除非腳本主機是可信的，否則 XMLHTTP（客戶端對象）不允許訪問遠程對象（病毒）。 因此，Access 出現權限錯誤的原因是它沒有告訴 XMLHTTP 它擁有該權限。

我不太了解 XMLHTTP 信任設置。 看看信任中心（訪問）是否有幫助。

Answer 2

更新試試這個並報告：

這對我有用：

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