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

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