| koralek | Дата: Суббота, 23.02.2013, 18:53 | Сообщение # 1 |
|
Подполковник
Группа: Администраторы
Сообщений: 147
Статус: Offline
| При помощи этого макроса вы можете скачать текст с выбранной страницы веб-сайта:
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
|
| |
| |
