При помощи этого макроса вы можете скачать текст с выбранной страницы веб-сайта:

Sub ЗагрузкаТекстаВебСтраницы()

    Set IE = CreateObject("InternetExplorer.Application"):    ' загружаем браузер Internet Explorer

    On Error Resume Next

    addr$ = "http://excelvba.ru/services"    ' указываем адрес сайта (веб-страницы), текст которой загружаем

    IE.Navigate addr$    ' загружаем сайт

     While IE.busy Or (IE.readyState <> 4): DoEvents: Wend    ' ждем, пока загрузится страница

    ' Set ieDoc = IE.Document    ' ссылка на открытый документ

    txt$ = IE.Document.body.innerText    ' считываем текст веб-страницы в текстовую переменную

    '[a1] = txt$ ' помещаем текст веб-страницы на лист Excel

    IE.Quit: Set IE = Nothing    ' закрываем браузер

    MsgBox txt$, vbInformation, "Текст веб-страницы " & addr$ ' выводим сообщение с текстом с сайта

End Sub

То же самое - но в виде функции:

Function WebPageText(ByVal sURL As String) As String

    On Error Resume Next

    Set IE = CreateObject("InternetExplorer.Application"):    ' загружаем браузер Internet Explorer

    IE.Navigate sURL    ' загружаем сайт

    While IE.busy Or (IE.readyState <> 4): DoEvents: Wend    ' ждем, пока загрузится страница

    WebPageText = IE.Document.body.innerText    ' считываем текст веб-страницы

    IE.Quit: Set IE = Nothing    ' закрываем браузер

End Function

Пример использования этой функции для загрузки текста страниц из интернета:

Sub ПримерИспользованияФункции_WebPageText()

    ' считываем текст страницы <a href="http://excelvba.ru/services" title="http://excelvba.ru/services">http://excelvba.ru/services</a> в переменную txt

    txt = WebPageText("http://excelvba.ru/services")

    ' получаем путь к папке "Рабочий стол"

    ПутьКРабочемуСтолу = CreateObject("WScript.Shell").SpecialFolders("Desktop")

    ' сохраняем текст из переменной txt в файл PageText.txt на рабочем столе

    SaveTXTfile ПутьКРабочемуСтолу & "\PageText.txt", txt

    ' открываем созданный текстовый файл в Excel

    Workbooks.OpenText ПутьКРабочемуСтолу & "\PageText.txt", , , xlDelimited

End Sub

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean

    On Error Resume Next: Err.Clear

    Set fso = CreateObject("scripting.filesystemobject")

    Set ts = fso.CreateTextFile(filename, True)

    ts.Write txt: ts.Close

    SaveTXTfile = Err = 0

    Set ts = Nothing: Set fso = Nothing

End Function

PS: Если вас интересует ИСХОДНЫЙ КОД страницы - используйте эту функцию: http://excelvba.ru/code/GetHTTPResponse

• 36763 просмотра