Скачать текст веб-страницы через WScript.Shell

@A_nAs_tAsi_A · Регистрация: 21.08.2020

Студворк — интернет-сервис помощи студентам

Добрый день!
У меня есть вот такой вот код:

Visual Basic
1
2
3
4
 sURL = TextBox1.Value
    With CreateObject("WScript.Shell")
        .Run sURL
    End With

Он, по факту просто открывает сайт по введенной пользователем ссылке. Подскажите как можно записать в переменную html-код этой страницы??
Я знаю, что это можно сделать таким способом:

Visual Basic
1
2
3
4
5
With oXMLHTTP
        .Open "GET", sURL, False
        .send
    End With
    GetHTTPResponse = oXMLHTTP.responseText

но при его выполнении все русские символы в запросе не читаются, потому приходится искать другие пути)

Подскажите, пожалуйста, как необходимо поправить код или направление, в котором мне следует искать.

passedbyz · 07.12.2020, 18:33

A_nAs_tAsi_A, а как выглядят не читаемые русские символы - можете показать?

@A_nAs_tAsi_A · 07.12.2020, 18:51 **[ТС]**

Заменяет на знаки "?", а в поисковой строке они читаются как любые символы, то есть на результат запроса это не влияет никак.
Например, в ссылке
https://zakupki.gov.ru/epz/ord... General=-1
В данном случае слово "поверк"( идет после search string до morphology)

@A_nAs_tAsi_A · 07.12.2020, 19:59 **[ТС]**

passedbyz, выглядит все это следющим образом:

@amd48 · 08.12.2020, 08:13

Сообщение от A_nAs_tAsi_A

но при его выполнении все русские символы в запросе не читаются

такой код?

Visual Basic
1
2
3
4
5
6
7
8
sURL = "https://zakupki.gov.ru/epz/order/extendedsearch/results.html?searchString=%D0%9F%D0%BE%D0%B2%D0%B5%D1%80%D0%BA&morphology=on&search-filter=%D0%94%D0%B0%D1%82%D0%B5+%D1%80%D0%B0%D0%B7%D0%BC%D0%B5%D1%89%D0%B5%D0%BD%D0%B8%D1%8F&pageNumber=1&sortDirection=false&recordsPerPage=_10&showLotsInfoHidden=false&sortBy=UPDATE_DATE&fz44=on&fz223=on&af=on&ca=on&pc=on&pa=on&currencyIdGeneral=-1"
    
    Set oXMLHTTP = WScript.CreateObject("Microsoft.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
    End With
    GetHTTPResponse = oXMLHTTP.responseText

У меня кириллица читается. Например:

Visual Basic
1
2
3
4
5
6
7
8
9
    sURL="https://ya.ru"
    Set oXMLHTTP = WScript.CreateObject("Microsoft.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
    End With
    GetHTTPResponse = oXMLHTTP.responseText
 
    msgbox GetHTTPResponse

@A_nAs_tAsi_A · 08.12.2020, 09:36 **[ТС]**

amd48, проблема в том что он заменяет кириллицу в поисковой строке этого сайта, а в остальном запрос выполняется корректно

@amd48 · 08.12.2020, 10:48

Сообщение от A_nAs_tAsi_A

в поисковой строке этого сайта

0,5 секунды в гугле:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
    sURL="https://yandex.ru/search/?text=" & RussianStringToURLEncode("аля улю")
    Set oXMLHTTP = WScript.CreateObject("Microsoft.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
    End With
    GetHTTPResponse = oXMLHTTP.responseText
 
    With CreateObject("WScript.Shell")
        .Run sURL
    End With
 
    msgbox GetHTTPResponse
 
 
Function RussianStringToURLEncode(txt)
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        if AscW(l) > 256 Then
            t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
        elseif AscW(l) = 32 Then
            t = "+"
        Else: t = l
        End If
        RussianStringToURLEncode = RussianStringToURLEncode & t
    Next
End Function

@A_nAs_tAsi_A · 08.12.2020, 17:56 **[ТС]**

amd48, Извините, в начале несколько строчек не хватает во втором коде, не обратила на это внимание в начале.

Visual Basic
1
2
3
4
5
6
7
8
On Error Resume Next
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    sURL = Textbox1.Value
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
    End With
    GetHTTPResponse = oXMLHTTP.responseText

Когда пытаюсь прогнать ваш код, вылетает ошибка. В чем может быть проблема?

@amd48 · 08.12.2020, 21:15

Зачем эти скриншоты во весь экран, если нет ни слова о том, в какой строке кода эта ошибка выдалась? Я должен угадывать?
On Error Resume Next игнорирует все ошибки. Пока не разберётесь с алгоритмом процедуры, эта директива только мешает. Как капли в нос при гриппе. Соплей нет, но и лечения - тоже

@A_nAs_tAsi_A · 09.12.2020, 03:47 **[ТС]**

amd48, ошибка появляется на этой строчке
Set oXMLHTTP = WScript.CreateObject("Microsoft.XMLHTTP" )

@Punkt5 · 09.12.2020, 11:25

A_nAs_tAsi_A, попробуйте взять свой код, поправив в нём строчку:

Сообщение от A_nAs_tAsi_A

sURL = Textbox1.Value

заменив код с простого копирования строки в переменную на копирование с преобразованием русских символов, как выше приведённо у amd48:

Visual Basic
1
sURL = RussianStringToURLEncode(Textbox1.Value)

И не забудьте положить рядом саму функцию

Сообщение от amd48

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
Function RussianStringToURLEncode(txt)
 For i = 1 To Len(txt)
 l = Mid(txt, i, 1)
 if AscW(l) > 256 Then
 t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
 elseif AscW(l) = 32 Then
 t = "+"
 Else: t = l
 End If
 RussianStringToURLEncode = RussianStringToURLEncode & t
 Next
End Function

@A_nAs_tAsi_A · 09.12.2020, 15:45 **[ТС]**

Punkt5,

Сообщение от Punkt5

попробуйте взять свой код, поправив в нём строчку:
Сообщение от A_nAs_tAsi_A
sURL = Textbox1.Value
заменив код с простого копирования строки в переменную на копирование с преобразованием русских символов, как выше приведённо у amd48:
Visual BasicВыделить код
1
sURL = RussianStringToURLEncode(Textbox1.Value)

Увы, не помогло к сожалению
Не знаю, может я не вижу какой-то очевидной ошибки.

@A_nAs_tAsi_A · 09.12.2020, 15:50 **[ТС]**

Вот файл с исполняемым кодом

@Punkt5 · 09.12.2020, 16:45

Сообщение от A_nAs_tAsi_A

от файл с исполняемым кодом

Размер файла архива 39 байт - явный сбой при архивации.

@A_nAs_tAsi_A · 09.12.2020, 16:55 **[ТС]**

Punkt5,

Сообщение от Punkt5

явный сбой при архивации.

@Punkt5 · 09.12.2020, 17:28

Удалил пару лишних строк, поскольку после

Code
1
sURL = RussianStringToURLEncode(Textbox1.Value)

оставлять парой строк ниже

Code
1
sURL = Textbox1.Value

это просто ошибка.
Вот окончательный код вашего макроса:

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Private Sub CommandButton1_Click()
    sURL = RussianStringToURLEncode(TextBox1.Value)
    MsgBox sURL
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
    End With
    GetHTTPResponse = oXMLHTTP.responseText
    
    HomeDir$ = ThisWorkbook.Path
    Open HomeDir$ + "\file2.txt" For Output As #1
    Print #1, CStr(GetHTTPResponse)
    Close #1
    Set oXMLHTTP = Nothing
        
    Workbooks.OpenText Filename:=HomeDir$ + "\file2.txt"
    With ActiveWorkbook
        .ActiveSheet.UsedRange.Copy ThisWorkbook.Sheets(1).[A1].Cells
        .Close (True)
    End With
End Sub
 
Function RussianStringToURLEncode(txt)
    For i = 1 To Len(txt)
        l = Mid(txt, i, 1)
        If AscW(l) > 256 Then
            t = "%" & Hex(AscW(l) \ 64 + 192) & "%" & Hex(8 * 16 + AscW(l) Mod 64)
        ElseIf AscW(l) = 32 Then
            t = "+"
        Else: t = l
        End If
        RussianStringToURLEncode = RussianStringToURLEncode & t
    Next
End Function

Вроде всё работает на вашей же вышеприведённой строке запроса.

@A_nAs_tAsi_A · 09.12.2020, 19:46 **[ТС]**

Punkt5, Спасибо огромное

Сообщение от Punkt5

оставлять парой строк ниже
КодВыделить код
sURL = Textbox1.Value
это просто ошибка.

Очень глупая ошибка....
Еше раз большое спасибо

Новые блоги и статьи Все статьи Все блоги /
Перемещение выделенных строк ТЧ из одного документа в другой Maks 30.03.2026 Реализация из решения ниже выполнена на примере нетипового документа "ВыдачаОборудованияНаСпецтехнику" с единственной табличной частью "ОборудованиеИКомплектующие" разработанного в конфигурации КА2. . . .	Functional First Web Framework Suave DevAlt 30.03.2026 Sauve. IO Апнулись до NET10. Из зависимостей один пакет, работает одинаково хорошо как в режиме проекта так и в интерактивном режиме. из сложностей - чисто функциональный подход. Решил. . .	Автоматическое создание документа при проведении другого документа Maks 29.03.2026 Реализация из решения ниже выполнена на нетиповых документах, разработанных в конфигурации КА2. Есть нетиповой документ "ЗаявкаНаРемонтСпецтехники" и нетиповой документ "ПланированиеСпецтехники". В. . .	Настройка движения справочника по регистру сведений Maks 29.03.2026 Решение ниже реализовано на примере нетипового справочника "ТарифыМобильнойСвязи" разработанного в конфигурации КА2, с целью учета корпоративной мобильной связи в коммерческом предприятии. . . .
Автозаполнение реквизита при выборе элемента справочника Maks 27.03.2026 Программный код из решения ниже на примере нетипового документа "ЗаявкаНаРемонтСпецтехники" разработанного в конфигурации КА2. При выборе "Спецтехники" (Тип Справочник. Спецтехника), заполняется. . .	Сумматор с применением элементов трёх состояний. Hrethgir 26.03.2026 Тут. https:/ / fips. ru/ EGD/ ab3c85c8-836d-4866-871b-c2f0c5d77fbc Первый документ красиво выглядит, но без схемы. Это конечно не даёт никаких плюсов автору, но тем не менее. . . всё может быть. . .	Автозаполнение реквизитов при создании документа Maks 26.03.2026 Программный код из решения ниже размещается в модуле объекта документа, в процедуре "ПриСозданииНаСервере". Алгоритм проверки заполнения реализован для исключения перезаписи значения реквизита,. . .	Команды формы и диалоговое окно Maks 26.03.2026 1. Команда формы "ЗаполнитьЗапчасти". Программный код из решения ниже на примере нетипового документа "ЗаявкаНаРемонтСпецтехники" разработанного в конфигурации КА2. В качестве источника данных. . .

passedbyz Заблокирован
	07.12.2020, 18:33
	A_nAs_tAsi_A, а как выглядят не читаемые русские символы - можете показать? 0

@A_nAs_tAsi_A 0 / 0 / 0 Регистрация: 21.08.2020 Сообщений: 51
	07.12.2020, 18:51 [ТС]
	Заменяет на знаки "?", а в поисковой строке они читаются как любые символы, то есть на результат запроса это не влияет никак. Например, в ссылке https://zakupki.gov.ru/epz/ord... General=-1 В данном случае слово "поверк"( идет после search string до morphology) 0

@A_nAs_tAsi_A 0 / 0 / 0 Регистрация: 21.08.2020 Сообщений: 51
	07.12.2020, 19:59 [ТС]
	passedbyz, выглядит все это следющим образом: Миниатюры 0

@A_nAs_tAsi_A 0 / 0 / 0 Регистрация: 21.08.2020 Сообщений: 51
	08.12.2020, 09:36 [ТС]
	amd48, проблема в том что он заменяет кириллицу в поисковой строке этого сайта, а в остальном запрос выполняется корректно 0

@amd48 845 / 475 / 80 Регистрация: 18.05.2016 Сообщений: 1,267 Записей в блоге: 5
	08.12.2020, 21:15
	Зачем эти скриншоты во весь экран, если нет ни слова о том, в какой строке кода эта ошибка выдалась? Я должен угадывать? On Error Resume Next игнорирует все ошибки. Пока не разберётесь с алгоритмом процедуры, эта директива только мешает. Как капли в нос при гриппе. Соплей нет, но и лечения - тоже 0

@A_nAs_tAsi_A 0 / 0 / 0 Регистрация: 21.08.2020 Сообщений: 51
	09.12.2020, 03:47 [ТС]
	amd48, ошибка появляется на этой строчке Set oXMLHTTP = WScript.CreateObject("Microsoft.XMLHTTP" ) 0

Скачать текст веб-страницы через WScript.Shell

Решение