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

Авторизация на Яндексе с использованием WinHttpRequest

Приведённый ниже код выполняет авторизацию на Яндексе, отправляя GET и POST запрос

На время POST запроса отключается автоматический редирект, чтобы сохранить Cookies, переданные в ответе сервера

PS: Код предназначен для специалистов!
Я не готов отвечать на вопросы, почему у вас не получилось авторизоваться, и что делать с этим макросом дальше (как получать данные)

Эта функция нашла применение в универсальной программе для сбора данных с Яндекс.Маркет

Public CookiesStore As Object        ' as Dictionary

 
Sub test_Yandex_Authentication()        ' пример использования

    If YM_Auth("MyLogin", "MyPassword") Then
        Debug.Print "Авторизация выполнена"
        Debug.Print "Сохранённые куки:", GetCookiesFromStore
    Else
        Debug.Print "Ошибка авторизации"
    End If
End Sub
Function YM_Auth(ByVal YM_login$, ByVal YM_password$) As Boolean
    ' © 2014 EducatedFool   ExcelVBA.ru
    ' функция выполняет авторизацию на Яндексе, принимая в качестве параметров логин и пароль
    ' возвращает TRUE, если авторизация выполнена

    ' в глобальном словаре CookiesStore сохраняет все куки, ответственные за авторизацию
    ' во всех дальнейших запросах надо использовать добавление заголовка COOKIE из этого хранилища
    ' при помощи строки кода .SetRequestHeader "Cookie", GetCookiesFromStore

On Error Resume Next
    Dim RequestTimeout&, wHTTP As Object, Response$, ResponseHeaders$, URL$
    Const StartURL$ = "http://market.yandex.ru/"
    Const AuthURL$ = "https://passport.yandex.ru/auth"
 
    RequestTimeout& = 6        ' таймаут (в секундах) ожидания ответа от сервера
    Set wHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
    Set CookiesStore = CreateObject("Scripting.Dictionary")        ' ОБЯЗАТЕЛЬНО НУЖНА ГЛОБАЛЬНАЯ ПЕРЕМЕННАЯ CookiesStore !

    With wHTTP
        ' открываем произвольную страницу Яндекса, чтобы получить ID сессии
        .Open "GET", StartURL$, True
        AddStaticHeaders wHTTP        ' добавляем заголовки запроса (представляясь браузером Chrome)
        .Send
 
        If .WaitForResponse(RequestTimeout&) Then        ' если дождались ответа от сервера
            SaveCookiesFromResponseHeaders .GetAllResponseHeaders        ' запоминаем куки

            .Open "POST", AuthURL$, True        ' выполняем POST запрос для авторизации
            ' отключаем авторедирект, чтобы получать cookies при каждом редиректе
            .Option(WinHttpRequestOption_EnableRedirects) = False
 
            AddStaticHeaders wHTTP        ' добавляем заголовки запроса (представляясь браузером Chrome)
            .SetRequestHeader "Cookie", GetCookiesFromStore
            .SetRequestHeader "Host", "passport.yandex.ru" 
 
            Dim POST() As Byte, PostData$, timestamp$        ' отправка данных учётной записи
            timestamp$ = (Now - 25569) * 86400000        ' время в формате UNIX
            PostData$ = "login=" & YM_login$ & "&passwd=" & YM_password$ & _
                        "&timestamp=" & timestamp$ & "&retpath=http://market.yandex.ru/"
            POST = StrConv(PostData, vbFromUnicode)
            .Send (POST): DoEvents
 
            If .WaitForResponse(RequestTimeout&) Then
                If .Status Like "30*" Then        ' если произошёл редирект, - значит, мы авторизовались успешно
                    SaveCookiesFromResponseHeaders .GetAllResponseHeaders        ' запоминаем куки
                    YM_Auth = True
                End If
            Else
                Debug.Print "Request Timeout (" & RequestTimeout & " seconds)", AuthURL$        ' истекло время ожидания
            End If
        Else
            Debug.Print "Request Timeout (" & RequestTimeout & " seconds)", StartURL$        ' истекло время ожидания
        End If
        .Option(WinHttpRequestOption_EnableRedirects) = True
    End With
    Set wHTTP = Nothing
End Function
Sub AddStaticHeaders(ByRef wHTTP As Object)
    On Error Resume Next
    With wHTTP
        '.SetRequestHeader "Host", "market.yandex.ru"
        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.131 Safari/537.36"
        .SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
        .SetRequestHeader "Connection", "keep-alive": .SetRequestHeader "Cache-Control", "no-cache"
        .SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .SetRequestHeader "Origin", "http://market.yandex.ru"
        .SetRequestHeader "Referer", "http://market.yandex.ru/"
    End With
End Sub
Function TextBetween(ByVal txt$, ByVal part1$, ByVal part2$, ByVal sep$) As String
    ' функция ищет в текстовой строке TXT блоки, начинающиеся текстом part1$, и заканчивающиеся текстом part2$
    ' возвращает массив найденных значений (объединённых в одну строку через разделитель sep$)
    On Error Resume Next
    Dim arr, i, res$
    Select Case ""
        Case part1$ & part2$: TextBetween = txt: Exit Function
        Case part1$: arr = Split(txt, part2$): arr(UBound(arr)) = ""
        Case part2$: arr = Split(txt, part1$): arr(0) = ""
        Case Else: arr = Split(txt, part1$)
            arr(0) = ""
            For i = LBound(arr) To UBound(arr)
                If InStr(1, arr(i), part2$, vbTextCompare) Then arr(i) = Split(arr(i), part2$)(0) Else arr(i) = ""
            Next i
    End Select
    txt = Join(arr, sep$)
    If sep$ = "" Then TextBetween = txt: Exit Function
    While InStr(1, txt$, sep$ & sep$, vbBinaryCompare): txt$ = Replace(txt$, sep$ & sep$, sep$): Wend
    If txt$ Like "*" & sep$ Then txt = Left(txt, Len(txt) - Len(sep$))
    If txt$ Like sep$ & "*" Then txt = Mid(txt, Len(sep$) + 1)
    TextBetween = txt
End Function
Function GetRedirectLocation(ByVal ResponseHeaders$, Optional CurrentURL$) As String
    ' если в заголовках ResponseHeaders$ есть заголовок Location,
    ' то функция возвращает путь для редиректа
    On Error Resume Next
    ResponseHeaders$ = Replace(ResponseHeaders$, "-Location", "")
    If InStr(1, ResponseHeaders$, "Location: ", vbTextCompare) = 0 Then Exit Function
 
    Dim URL$, BaseURL$: URL$ = Split(TextBetween(ResponseHeaders$, "Location: ", vbNewLine, vbNewLine), vbNewLine)(0)
    If IsURL(URL$) Then
        GetRedirectLocation = URL$
    Else
        If (URL$ Like "/*") And IsURL(CurrentURL$) Then
            BaseURL$ = Split(CurrentURL$, "://")(0) & "://" & Split(Split(CurrentURL$, "://")(1), "/")(0)
            GetRedirectLocation = BaseURL$ & URL$
        End If
    End If
    If Len(GetRedirectLocation) Then Debug.Print "redirect to " & GetRedirectLocation
End Function
 
Function IsURL(ByVal txt$) As Boolean
    IsURL = IsURL Or (txt$ Like "http://?*.?*")
    IsURL = IsURL Or (txt$ Like "https://?*.?*")
End Function
 
Function SaveCookiesFromResponseHeaders(ByVal txt$)
    On Error Resume Next
    Dim cookies$, item, param_name$, param_value$
    cookies$ = TextBetween(txt$, "Set-Cookie: ", vbNewLine, "; ")
 
    For Each item In Split(cookies$, "; ")
        param_name$ = "": param_value$ = ""
        param_name$ = Split(item, "=", 2)(0)
        param_value$ = Split(item, "=", 2)(1)
        If Len(param_name$) Then CookiesStore.item(param_name$) = param_value$
    Next
End Function
Function GetCookiesFromStore() As String
    On Error Resume Next: Dim key, v$
    For Each key In CookiesStore.Keys
        v$ = CookiesStore(key)
        GetCookiesFromStore = GetCookiesFromStore & "; " & key & IIf(v$ = "", "", "=" & v$)
    Next
    GetCookiesFromStore = Mid(GetCookiesFromStore, 3)
End Function

Комментарии

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

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

Александр, править код нужно, раз сайт поменялся.

Доброго времени суток!
Сейчас при загрузке произвольной стартовой страницы яндекс перестал присылать id сессии "_ym_uid". Как быть?

Понял, спасибо

Павел, я выдрал этот код из своей программы
http://excelvba.ru/programmes/YandexMarket
потому, могут быть неточности, и лишние куски кода

что у вас не объявлена вот эта переменная: WinHttpRequestOption_EnableRedirects

да, не заметил
у меня в коде просто подключена библиотека WinHTTP, - потому, ошибки не было

по региону - не помню, там что-то поменялось, я переделывал
Воспользуйтесь готовой программой, - там есть и авторизация, и выбор региона, и можно настроить, что куда выводить
(вчера залил обновлённую версию, - под новый сайт Яндекс Маркета)
http://excelvba.ru/programmes/YandexMarket

Спасибо, всё получилось.

Заметил, что у вас не объявлена вот эта переменная: WinHttpRequestOption_EnableRedirects
В интернете нашёл, что она должна быть числом 6. Можно её так объявить?
Const WinHttpRequestOption_EnableRedirects = 6&

Так же заметил, что у вас в коде есть процедура GetRedirectLocation, но она нигде не используется в коде. Зачем она нужна? Может её нужно вызвать где-то?

А вы не знаете, как можно поменять регион в Яндексе (на странице https://tune.yandex.ru/region/), но я так понимаю, что это тоже нужно сделать из под сохранённых авторизованных Cookie. Т.е. сперва авторизоваться, сохранить Cookie, зайти на https://tune.yandex.ru/region/ там поменять регион на другой и уже далее переходить по ссылкам всё время подставляя сохранённые Cookie.

Или можно как-то через код поменять регион в Яндексе без регистрации и далее переходить по ссылкам с сохранёнными Cookie, но с уже изменённым регионом.

Заранее благодарю.

Здравствуйте, Павел.
В вашем коде всё правильно, — видимо, это мой код стал неактуальным, после того как Яндекс.Маркет месяц назад переделал сайт
(когда я писал этот макрос, месяца 2-3 назад, всё работало как надо)

Чтобы заработало, надо в мою функцию добавить пару строк:
(про первую забыл изначально, второй сейчас стало нехватать)

.SetRequestHeader "Cookie", GetCookiesFromStore
.SetRequestHeader "Host", "passport.yandex.ru"

и доработать функцию добавления заголовков (там не все нужные были):

Sub AddStaticHeaders(ByRef wHTTP As Object)
    On Error Resume Next
    With wHTTP
        '.SetRequestHeader "Host", "market.yandex.ru"
        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.131 Safari/537.36"
        .SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
        .SetRequestHeader "Connection", "keep-alive": .SetRequestHeader "Cache-Control", "no-cache"
        .SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,*/*;q=0.8"
        .SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .SetRequestHeader "Origin", "http://market.yandex.ru"
        .SetRequestHeader "Referer", "http://market.yandex.ru/"
    End With
End Sub

Исправил код в статье, проверьте

Добрый день.

А как проверить, действительно ли мы авторизовались?

Пытаюсь проверить таким образом

Dim RequestTimeout&, wHTTP As Object, Response$, ResponseHeaders$, URL$

URL$ = "http://market.yandex.ru/product/10576047/offers?hid=6427100&hyperid=10576047&grhow=shop&track=tabs"
Set wHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
With wHTTP
.Open "GET", URL$, True
.SetRequestHeader "Connection", "keep-alive"
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/34.0.1847.131 Safari/537.36"
.SetRequestHeader "Cookie", GetCookiesFromStore
.Send
Response$ = .ResponseText
End With
Set wHTTP = Nothing

Но в переменной Response$ - всё равно есть текст "Войти", т.е. получается я не авторизован на сайте.

И вот это условие в процедуре YM_Auth выполняется всегда
If .Status Like "30*" Then ' если произошёл редирект, - значит, мы авторизовались успешно

Если поставить точку останова на этой строке и посмотреть текущий Status, то там указано

: Status : 301
: StatusText : "Moved Permanently"

Как бы исправить...

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

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

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

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