mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Авторизация на веб-сервере средствами VBA

Функция ConnectServer предназначена для автоматизации авторизации на сайте, выполняемой путем заполнения полей с логином и паролем, и нажатием кнопки "Отправить" (т.н. "форма входа на сайт")

Если вам требуется готовое решение для авторизации на сайте из Excel, — посмотрите надстройку Парсер сайтов
Там можно настроить авторизацию в пару действий, без единой строки кода

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

Public Const URL_Login = "http://www.mysite.ru/private/login.php"    ' страница входа
Public Const URL_LoginOK = "http://www.mysite.ru/private/"    ' сюда попадем, если вход удался
Public Const URL_main = "http://www.mysite.ru/documents/add.php"    ' а эта страница сайта нам нужна для работы

Sub ПримерИспользования_ConnectServer()
    ' Dim IE As SHDocVw.InternetExplorer, IEdoc As HTMLDocument
    On Error Resume Next
    Set IE = ConnectServer    ' авторизуемся на сервере

    Set IEdoc = IE.Document    ' получаем ссылку на документ

    ' заполняем поля на сайте
    SetSelectElementValue IEdoc, "region", Город
    SetSelectElementValue IEdoc, "district", Район
    SetInputElementValue IEdoc, "body", Comment
 
    ' отправляем данные на сервер
    IEdoc.getElementsByName("add_form").Item(0).submit
 
    IE.Quit ' закрываем браузер
End Sub

Код функции ConnectServer:

Function ConnectServer() As Object
    ' функция предназначена для авторизации на сайтах
    ' (ввод логина и пароля через веб-интерфейс)
    ' Возвращает объект типа InternetExplorer с загруженной страницей сайта, где мы авторизовались
    ' НЕНУЖНЫЕ СТРОКИ КОДА ЗАКОММЕНТИРОВАНЫ

    Login$ = "admin": Password$ = "password"    ' укажите здесь логин и пароль для сайта
    On Error Resume Next: Err.Clear
    ' Dim pi As New ProgressIndicator
    ' pi.Show "Отправка объявлений на сайт риэлторского агенства..."
    ' pi.StartNewAction 5, 10, "Установка соединения с сервером ..."
    Set IE = CreateObject("InternetExplorer.Application")
    ' IE.Visible = True ' для тестирования
    
    ' pi.StartNewAction 10, 50, "Загрузка страницы авторизации ...", , , 10
    IE.Navigate URL_Login
    ' ждём, пока страница загрузиться
    '    t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
    '        DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
    '    Wend: DoEvents
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
    ' pi.StartNewAction 50, 80, "Авторизация на сервере...", , , 15
    
    Set IEdoc = IE.Document: DoEvents: DoEvents
 
    ' заполняем поля с логином и паролем
    IEdoc.getElementsByName("login_r").Item(0).Value = Login$
    IEdoc.getElementsByName("passwd_r").Item(0).Value = Password$
    ' и отправляем данные формы на сервер
    IEdoc.getElementsByName("login_form").Item(0).submit
 
    If Err Then MsgBox "Не удаётся загрузить страницу", vbCritical: End
    ' ждём, пока страница загрузиться
    '    t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
    '        DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
    '    Wend
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
    If IE.LocationURL <> URL_LoginOK Then
        MsgBox "Логин или пароль неверны!", vbCritical, "Ошибка авторизации": pi.Hide: End
    End If
 
    ' pi.StartNewAction 80, 100, "Загрузка страницы отправки объявлений ...", , , 10
    IE.Navigate URL_main
    ' ждём, пока страница загрузиться
    '    t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
    '        DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
    '    Wend
    While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
    Set ConnectServer = IE
    ' pi.Hide
End Function

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Удалите эти строки, - к данному примеру они отношения не имеют, а необходимый код (этих функций) у меня утерян.
Суть функции, - в авторизации, и возврате объекта, ссылающегося на документ IE

Подскажите, какие библиотеки надо подключать, все эти вещи компилятор не пропускает SetSelectElementValue, SetSelectElementValue IEdoc, SetInputElementValue IEdoc

Нет
Код использует компоненты Windows, которых на Mac просто нет
Для Mac можно написать аналогичный по функционалу код, - но он будет совсем другим

Здравствуйте! подскажите можно ли исправить этот код для работы на macOS?

СПАСИБО!!!! И за пример и за оперативность! Я вам очень благодарна!

Выложил пример нужного вам кода (загрузка файла с авторизацией):
http://excelvba.ru/code/DownloadFileWithAuth

Спасибо, за ответ! Буду с нетерпением ждать, надеюсь всё таки способ найду, с авторизацией же разобралась. Решение уже близко, по крайней мере, хочется в это верить.

да, есть способ скачать файл с авторизацией
но там совсем другой код, и он сложнее
кроме того, по каждый сайт авторизация выполняется по-разному
Навскидку не могу дать пример кода.
Если будет время, - как-нибудь опубликую отдельной статьёй.

Добрый день спасибо за ваши подсказки, благодаря вашей статье и ещё на одном сайте, настроила авторизацию на сайт, переходы по ссылкам работают, да вот беда когда начинаешь закачивать файлы по средством:
Function DownloadFile(FromPathName, ToPathName) As Boolean
DownloadFile = URLDownloadToFile(0, FromPathName, ToPathName, 0, 0) = 0
End Function

URL$ = ""
FileName$ = ""
IE.Navigate URL$
Set ieDoc = IE.Document: DoEvents: DoEvents
DownloadFile URL$, FileName$.
Качается файл с содержимым окна о не пройденной авторизации, может подскажете как обойти это? Может есть ещё какой то метод?

Здравствуйте, Денис.

Что могу сказать:
1) в функции ConnectServer куча ошибок, - что за символы ";" появились?
вы разве не видите, что VBA эти строки красным подсвечивает?
2) функция ConnectServer не имеет никакого отношения к веб-запросу (QueryTables.Add)
так что совмещение этих 2 способов подключения к сайту ничего не даст
3) код пишется под конкретный сайт
чтобы протестировать его, надо знать адрес конкретного сайта, и действующие логин с паролем
4) хотите готовый макрос? Оформляйте заказ, и прикрепляйте пример результата.
Работы тут много, - там что это не бесплатно.

Прошу помощи у Гуру. Не могу понять, где ошибка закралась. Целиком и пошагово скрипт отрабатывает без ошибок, в Excel'е создается подключение и диапазон, в который почему-то переносится только 2 пустые ячейки. Предыстория: есть портал, необходимо на нем авторизоваться и затем по некоторому адресу забрать в Excel табличку с некоторым id. Вот код:

 
Public Const URL_Login = "http://aaa.com/" ' страница входа
Public Const URL_LoginOK = "http://aaa.com/Supplier" ' сюда попадем, если вход удался
Public Const URL_main = "http://aaa.com/Supplier" ' а эта страница сайта нам нужна для работы
Sub GetForfeits_ConnectServer()
 
 On Error Resume Next
 Set IE = ConnectServer ' авторизуемся на портале
 Set IEdoc = IE.Document ' получаем ссылку на документ
 
 'Выполняем добавление запроса таблички "markup" по адресу aaa.com/Supplier
 With ActiveSheet.QueryTables.Add(Connection:= _
 "URL;http://aaa.com/Supplier", Destination:=Range("$A$2"  ;)  )
 .Name = "Supplier"
 .FieldNames = True
 .RowNumbers = False
 .FillAdjacentFormulas = False
 .PreserveFormatting = True
 .RefreshOnFileOpen = False
 .BackgroundQuery = True
 .RefreshStyle = xlOverwriteCells
 .SavePassword = False
 .SaveData = True
 .AdjustColumnWidth = True
 .RefreshPeriod = 0
 .WebSelectionType = xlSpecifiedTables
 .WebFormatting = xlWebFormattingNone
 .WebTables = """markup"""
 .WebPreFormattedTextToColumns = True
 .WebConsecutiveDelimitersAsOne = True
 .WebSingleBlockTextImport = False
 .WebDisableDateRecognition = False
 .WebDisableRedirections = False
 .Refresh BackgroundQuery:=False
 End With
 IE.Quit ' закрываем браузер
End Sub
 
Function ConnectServer() As Object
 
 
 Login$ = "xxxx": Password$ = "yyyy" ' укажите здесь логин и пароль для сайта
 On Error Resume Next: Err.Clear
 Set IE = CreateObject("InternetExplorer.Application"  ;)  
 IE.Visible = True ' для тестирования
 
 
 IE.Navigate URL_Login
 While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
 Set IEdoc = IE.Document: DoEvents: DoEvents
 
 ' заполняем поля с логином и паролем
 IEdoc.getElementsByName("login"  ;)  .Item(0).Value = Login$
 IEdoc.getElementsByName("password"  ;)  .Item(0).Value = Password$
 ' и жмем на кнопку "Войти"
 IEdoc.getElementsByName("btn-submit"  ;)  .Item(0).Click
 
 If Err Then MsgBox "Не удаётся загрузить страницу", vbCritical: End
 While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
 If IE.LocationURL <> URL_LoginOK Then
 MsgBox "Логин или пароль неверны!", vbCritical, "Ошибка авторизации": Pi.Hide: End
 End If
 
 IE.Navigate URL_main
 While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
 Set ConnectServer = IE
 ' pi.Hide
End Function

попробовал использовать этот код для своих целей, поля авторизации заполняет правильно, а вот нажать на кнопку не получается.
Помогите, как из VBA нажать на кнопку "войти" на сайте:
www_heroeswm_ru

у меня почему то не работает команда submit. тоесть все данные вбиваются но приходиться нажимать вручную!

Public Const URL_Login = "https://www.atsenergo.ru/auth" ' ñòðàíèöà âõîäà
Public Const URL_LoginOK = "https://www.atsenergo.ru/reporting/personal/" ' ñþäà ïîïàäåì, åñëè âõîä óäàëñÿ
Public Const URL_main = "https://www.atsenergo.ru/reporting/personal/eur/sell_norem/20130922" ' à ýòà ñòðàíèöà ñàéòà íàì íóæíà äëÿ ðàáîòû

Sub ÏðèìåðÈñïîëüçîâàíèÿ_ConnectServer()
' Dim IE As SHDocVw.InternetExplorer, IEdoc As HTMLDocument
On Error Resume Next
Set IE = ConnectServer ' àâòîðèçóåìñÿ íà ñåðâåðå

Set IEdoc = IE.Document ' ïîëó÷àåì ññûëêó íà äîêóìåíò

IE.Quit ' çàêðûâàåì áðàóçåð
End Sub

Function ConnectServer() As Object
' ôóíêöèÿ ïðåäíàçíà÷åíà äëÿ àâòîðèçàöèè íà ñàéòàõ
' (ââîä ëîãèíà è ïàðîëÿ ÷åðåç âåá-èíòåðôåéñ)
' Âîçâðàùàåò îáúåêò òèïà InternetExplorer ñ çàãðóæåííîé ñòðàíèöåé ñàéòà, ãäå ìû àâòîðèçîâàëèñü
' ÍÅÍÓÆÍÛÅ ÑÒÐÎÊÈ ÊÎÄÀ ÇÀÊÎÌÌÅÍÒÈÐÎÂÀÍÛ

Login$ = "лялялял": Password$ = "ляляля " ' óêàæèòå çäåñü ëîãèí è ïàðîëü äëÿ ñàéòà
On Error Resume Next: Err.Clear
' Dim pi As New ProgressIndicator
' pi.Show "Îòïðàâêà îáúÿâëåíèé íà ñàéò ðèýëòîðñêîãî àãåíñòâà..."
Pi.StartNewAction 5, 10, "Óñòàíîâêà ñîåäèíåíèÿ ñ ñåðâåðîì ..."
Set IE = CreateObject("InternetExplorer.Application")
' IE.Visible = True ' äëÿ òåñòèðîâàíèÿ
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True ' äëÿ òåñòèðîâàíèÿ
IE.Silent = True 'ïîäàâëåíèå âñïëûâàþùèõ îêîí Explorer

' pi.StartNewAction 10, 50, "Çàãðóçêà ñòðàíèöû àâòîðèçàöèè ...", , , 10
IE.Navigate URL_Login
' æä¸ì, ïîêà ñòðàíèöà çàãðóçèòüñÿ
' t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
' DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
' Wend: DoEvents
While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend

' pi.StartNewAction 50, 80, "Àâòîðèçàöèÿ íà ñåðâåðå...", , , 15

Set IEdoc = IE.Document: DoEvents: DoEvents

' çàïîëíÿåì ïîëÿ ñ ëîãèíîì è ïàðîëåì
IEdoc.getElementsByName("j_usercode").Item(0).Value = Login$
IEdoc.getElementsByName("j_username").Item(0).Value = Login$
IEdoc.getElementsByName("j_password").Item(0).Value = Password$
' è îòïðàâëÿåì äàííûå ôîðìû íà ñåðâåð

IEdoc.getElementsByName("action").Item(0).submit
IE.Visible = True ' äëÿ òåñòèðîâàíèÿ
IE.Silent = True 'ïîäàâëåíèå âñïëûâàþùèõ îêîí Explorer

If Err Then MsgBox "Íå óäà¸òñÿ çàãðóçèòü ñòðàíèöó", vbCritical: End
' æä¸ì, ïîêà ñòðàíèöà çàãðóçèòüñÿ
' t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
' DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
' Wend
While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend

If IE.LocationURL <> URL_LoginOK Then
MsgBox "Ëîãèí èëè ïàðîëü íåâåðíû!", vbCritical, "Îøèáêà àâòîðèçàöèè": Pi.Hide: End
End If

' pi.StartNewAction 80, 100, "Çàãðóçêà ñòðàíèöû îòïðàâêè îáúÿâëåíèé ...", , , 10
IE.Navigate URL_main
' æä¸ì, ïîêà ñòðàíèöà çàãðóçèòüñÿ
' t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
' DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
' Wend
While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend

Set ConnectServer = IE
' pi.Hide
End Function

Нашел, вопрос решается с помощью кода после создания объекта IE:

Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = True ' для тестирования
IE.Silent = True 'подавление всплывающих окон Explorer

По завершения работы процедуры регистрации, выходит стандартное окно: "открыть или сохранить этот файл?" Где-то в интернете видел что это стандартное окно блокнота, как согласиться на сохранение файла?

В какой книге можно подробнее почитать о получении/передаче информации в интернете?

При обработки этого кода выходит сообщение "Отображать только безопасное содержимое веб-старниц?". Как с ним бороться если нет возможности отключить это всплывающее окно в IExplorer?

Обратите внимание на эти строки кода:

    ' заполняем поля с логином и паролем
    IEdoc.getElementsByName("login_r").Item(0).Value = Login$
    IEdoc.getElementsByName("passwd_r").Item(0).Value = Password$
    ' и отправляем данные формы на сервер
    IEdoc.getElementsByName("login_form").Item(0).submit

Названия полей login_r, passwd_r и формы login_form - подходят только для моего примера.
В вашем случае названия полей будут другие
(и, скорее всего, надо предварительно обработать ошибку отсутствия сертификата)

Это был лишь пример авторизации на сайте - под конкретный сайт код нужно дорабатывать.

Помоги пожалуйста! Что я сделал не так?

Public Const URL_Login = "https://br.so-ups.ru/Public/Login.aspx?ReturnUrl=%2fEntityDataView%2fGtp.aspx#"    ' страница входа
Public Const URL_LoginOK = "https://br.so-ups.ru/EntityDataView/Gtp.aspx"    ' сюда попадем, если вход удался
Public Const URL_main = "https://br.so-ups.ru/Export/Csv/Gtp.aspx?&date=24.01.2012&gtpIds=GIRKEN08"    ' а эта страница сайта нам нужна для работы

Sub ПримерИспользования_ConnectServer()
    ' Dim IE As SHDocVw.InternetExplorer, IEdoc As HTMLDocument
   On Error Resume Next
    Set IE = ConnectServer    ' авторизуемся на сервере

    Set IEdoc = IE.Document    ' получаем ссылку на документ

    ' заполняем поля на сайте
    SetSelectElementValue IEdoc, "login", Логин
    SetSelectElementValue IEdoc, "password", Пароль
   'SetInputElementValue IEdoc, "body", Comment

    ' отправляем данные на сервер
   IEdoc.getElementsByName("add_form").Item(0).submit
 
    IE.Quit ' закрываем браузер
End Sub
 
Function ConnectServer() As Object
    ' функция предназначена для авторизации на сайтах
   ' (ввод логина и пароля через веб-интерфейс)
   ' Возвращает объект типа InternetExplorer с загруженной страницей сайта, где мы авторизовались
   ' НЕНУЖНЫЕ СТРОКИ КОДА ЗАКОММЕНТИРОВАНЫ

    Login$ = "...": Password$ = "..."    ' укажите здесь логин и пароль для сайта
   On Error Resume Next: Err.Clear
    ' Dim pi As New ProgressIndicator
   ' pi.Show "Отправка объявлений на сайт риэлторского агенства..."
   ' pi.StartNewAction 5, 10, "Установка соединения с сервером ..."
   Set IE = CreateObject("InternetExplorer.Application")
    ' IE.Visible = True ' для тестирования
   
    ' pi.StartNewAction 10, 50, "Загрузка страницы авторизации ...", , , 10
   IE.Navigate URL_Login
    ' ждём, пока страница загрузиться
   '    t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
   '        DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
   '    Wend: DoEvents
   While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
    ' pi.StartNewAction 50, 80, "Авторизация на сервере...", , , 15
   
    Set IEdoc = IE.Document: DoEvents: DoEvents
 
    ' заполняем поля с логином и паролем
   IEdoc.getElementsByName("login_r").Item(0).Value = Login$
    IEdoc.getElementsByName("passwd_r").Item(0).Value = Password$
    ' и отправляем данные формы на сервер
   IEdoc.getElementsByName("login_form").Item(0).submit
 
    If Err Then MsgBox "Не удаётся загрузить страницу", vbCritical: End
    ' ждём, пока страница загрузиться
   '    t = Timer: While IE.Busy Or (IE.ReadyState <> 4)
   '        DoEvents: If Timer - t > 0.1 Then pi.SubAction: t = Timer
   '    Wend
   While IE.Busy Or (IE.ReadyState <> 4): DoEvents: Wend
 
    If IE.LocationURL <> URL_LoginOK Then
        MsgBox "Логин или пароль неверны!", vbCritical, "Ошибка авторизации": pi.Hide: End
    End If

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
  _       __  __  __   __  _       ____    _____ 
| |__ | \/ | \ \ / / | |__ | __ ) |_ _|
| '_ \ | |\/| | \ V / | '_ \ | _ \ | |
| | | | | | | | | | | |_) | | |_) | | |
|_| |_| |_| |_| |_| |_.__/ |____/ |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.