Лучший вариант (IMO) - использовать API Новостей Google и зарегистрироваться для получения ключа API. Затем вы можете использовать queryString, включающий ваш критерий поиска, и проанализировать ответ JSON, чтобы получить счетчик результатов. Я делаю это ниже, а также заполняю коллекцию заголовками статей и ссылками. Я использую синтаксический анализатор JSON JSONConverter.bas , который вы загружаете и добавляете в свой проект. Затем вы можете перейти к VBE> Инструменты> Ссылки> добавить ссылку на Microsoft Scripting Runtime.
Пример ответа JSON от API:
{} обозначает словарь, к которому вы обращаетесь по ключу, [] обозначает коллекцию, к которой вы обращаетесь по индексу или с помощью For Each зацикливания.
Я использую ключ totalResults, чтобы получить общее количество результатов из исходного словаря, возвращенного API.
Затем я делаю цикл по словарям (статьям) и извлекаю заголовки и URL-адреса историй.
Затем вы можете просмотреть результаты в окне местных жителей или распечатать
Пример результатов в окне местных жителей:
Option Explicit
Public Sub GetStories()
Dim articles As Collection, article As Object
Dim searchTerm As String, finalResults As Collection, json As Object, arr(0 To 1)
Set finalResults = New Collection
searchTerm = "Obama"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://newsapi.org/v2/everything?q=" & searchTerm & "&apiKey=yourAPIkey", False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
Set json = JsonConverter.ParseJson(.responseText)
End With
Debug.Print "total results = " & json("totalResults")
Set articles = json("articles")
For Each article In articles
arr(0) = article("title")
arr(1) = article("url")
finalResults.Add arr
Next
Stop '<== Delete me later
End Sub
Loop:
При развертывании в цикле вы можете использовать класс clsHTTP для хранения объекта XMLHTTP. Это эффективнее, чем создавать и уничтожать. Я предоставляю этому классу метод GetString для получения ответа JSON из API и метод GetInfo для синтаксического анализа JSON и получения количества результатов и URL-адресов и заголовков результатов API.
Пример структуры результатов в окне locals:
Класс clsHTTP:
Option Explicit
Private http As Object
Private Sub Class_Initialize()
Set http = CreateObject("MSXML2.XMLHTTP")
End Sub
Public Function GetString(ByVal url As String) As String
With http
.Open "GET", url, False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
GetString = .responseText
End With
End Function
Public Function GetInfo(ByVal json As Object) As Variant
Dim results(), counter As Long, finalResults(0 To 1), articles As Object, article As Object
finalResults(0) = json("totalResults")
Set articles = json("articles")
ReDim results(1 To articles.Count, 1 To 2)
For Each article In articles
counter = counter + 1
results(counter, 1) = article("title")
results(counter, 2) = article("url")
Next
finalResults(1) = results
GetInfo = finalResults
End Function
Стандартный модуль:
Option Explicit
Public Sub GetStories()
Dim http As clsHTTP, json As Object
Dim finalResults(), searchTerms(), searchTerm As Long, url As String
Set http = New clsHTTP
With ThisWorkbook.Worksheets("Sheet1")
searchTerms = Application.Transpose(.Range("A1:A2")) '<== Change to appropriate range containing search terms
End With
ReDim finalResults(1 To UBound(searchTerms))
For searchTerm = LBound(searchTerms, 1) To UBound(searchTerms, 1)
url = "https://newsapi.org/v2/everything?q=" & searchTerms(searchTerm) & "&apiKey=yourAPIkey"
Set json = JsonConverter.ParseJson(http.GetString(url))
finalResults(searchTerm) = http.GetInfo(json)
Set json = Nothing
Next
Stop '<==Delete me later
End Sub
'
В противном случае:
Я бы использовал следующее, где я беру ссылки на истории по имени класса. Я получаю счет и пишу ссылки на коллекцию
Option Explicit
Public Sub GetStories()
Dim sResponse As String, html As HTMLDocument, articles As Collection
Const BASE_URL As String = "https://news.google.com/"
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://news.google.com/topics/CAAqIggKIhxDQkFTRHdvSkwyMHZNRGxqTjNjd0VnSmxiaWdBUAE?hl=en-US&gl=US&ceid=US:en", False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
sResponse = StrConv(.responseBody, vbUnicode)
End With
Set html = New HTMLDocument: Set articles = New Collection
Dim numberOfStories As Long, nodeList As Object, i As Long
With html
.body.innerHTML = sResponse
Set nodeList = .querySelectorAll(".VDXfz")
numberOfStories = nodeList.Length
Debug.Print "number of stories = " & numberOfStories
For i = 0 To nodeList.Length - 1
articles.Add Replace$(Replace$(nodeList.item(i).href, "./", BASE_URL), "about:", vbNullString)
Next
End With
Debug.Print articles.Count
End Sub
Стандартный поиск Google:
Ниже приведен пример стандартного поиска в Google, но вы не всегда получите ту же структуру HTML в зависимости от вашего поискового запроса. Вам нужно будет указать некоторые случаи неудач, чтобы помочь мне определить, существует ли последовательный метод выбора, который можно применить.
Option Explicit
Public Sub GetResultsCount()
Dim sResponse As String, html As HTMLDocument
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.google.com/search?q=mitsubishi", False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
sResponse = StrConv(.responseBody, vbUnicode)
End With
Set html = New HTMLDocument
With html
.body.innerHTML = sResponse
Debug.Print .querySelector("#resultStats").innerText
End With
End Sub