在 MS-Access 中通过 VBA 进行 Google 搜索
Googlesearch via VBA in MS-Access
以下代码片段搜索 google 搜索公司名称。此代码适用于 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)"
现在我收到一条关于“签署 in/login”的回复文本。我是德语所以它告诉我“Anmelden”。
所以我仍然无法得到 google- 搜索结果。
一些想法？也许我如何获得正确的 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
这确实给出了权限错误：
https://www.google.com/search?q=bango+plc&tbm=nws
在 excel 它工作正常...
为什么 XMLHTTP 在 excel 中有效，但在访问中无效？
我试图将 msaccess 文件放在受信任的位置。没用
除非脚本主机是可信的，否则不允许 XMLHTTP（客户端对象）访问远程对象（病毒）。所以 Access 给出权限错误的原因是因为它没有告诉 XMLHTTP 它有那个权限。
我不太了解 XMLHTTP 信任设置。查看信任中心 (Access) 是否有帮助。
更新试试这个并报告：
这对我有用：
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
以下代码片段搜索 google 搜索公司名称。此代码适用于 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)"
现在我收到一条关于“签署 in/login”的回复文本。我是德语所以它告诉我“Anmelden”。
所以我仍然无法得到 google- 搜索结果。
一些想法？也许我如何获得正确的 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
这确实给出了权限错误： https://www.google.com/search?q=bango+plc&tbm=nws 在 excel 它工作正常...
为什么 XMLHTTP 在 excel 中有效，但在访问中无效？ 我试图将 msaccess 文件放在受信任的位置。没用
除非脚本主机是可信的，否则不允许 XMLHTTP（客户端对象）访问远程对象（病毒）。所以 Access 给出权限错误的原因是因为它没有告诉 XMLHTTP 它有那个权限。
我不太了解 XMLHTTP 信任设置。查看信任中心 (Access) 是否有帮助。
更新试试这个并报告：
这对我有用：
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