Аутентификация через SMTP сервер

[bvv70]

Нашел вот в инете код для отправки письма программно, но серверы теперь требуют аутентификации. Как отправить пароль и логин на сервер?

Код: Выделить всё

Option Explicit
Dim Response As String, Reply As Integer, DateNow As String
Dim first As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String, Ninth As String
Dim Start As Single, Tmr As Single


Sub SendEmail(MailServerName As String, FromName As String, _
FromEmailAddress As String, ToName As String, _
ToEmailAddress As String, EmailSubject As String, _
EmailBodyOfMessage As String)

Winsock1.LocalPort = 0 'Присваиваем нулю, чтобы можно было послать более одного письма

If Winsock1.State = sckClosed Then ' Проверяем закрыт ли сокет
DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") _
& " " & Format(Time, "hh:mm:ss") & "" & " -0600"

'Адрес отправителя
first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf

'Адрес получателя
Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf

'Дата отправления
Third = "Date:" + Chr(32) + DateNow + vbCrLf

'Имя отправителя
Fourth = "From:" + Chr(32) + FromName + vbCrLf

'Имя получателя
Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf

'Тема письма
Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf

'Текст письма
Seventh = EmailBodyOfMessage + vbCrLf

'Название программы
Ninth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf

'Объединяем сформированные значения переменных в одну главную переменную
Eighth = Fourth + Third + Ninth + Fifth + Sixth

'Установка протокола
Winsock1.Protocol = sckTCPProtocol
'Установка SMTP сервера
Winsock1.RemoteHost = MailServerName
'Установка адреса сервера
Winsock1.RemotePort = 25
'Установление связи
Winsock1.Connect

WaitFor ("220")

StatusTxt.Caption = "Соединяемся...."
StatusTxt.Refresh

Winsock1.SendData ("HELO yourdomain.com" + vbCrLf)
WaitFor ("250")
StatusTxt.Caption = "Соединение установлено"
StatusTxt.Refresh
Winsock1.SendData (first)
StatusTxt.Caption = "Отправляем сообщение"
StatusTxt.Refresh
WaitFor ("250")
Winsock1.SendData (Second)
WaitFor ("250")
Winsock1.SendData ("data" + vbCrLf)

WaitFor ("354")
Winsock1.SendData (Eighth + vbCrLf)
Winsock1.SendData (Seventh + vbCrLf)
Winsock1.SendData ("." + vbCrLf)
WaitFor ("250")
Winsock1.SendData ("quit" + vbCrLf)

StatusTxt.Caption = "Отключение"
StatusTxt.Refresh
WaitFor ("221")
Winsock1.Close
Else
MsgBox (Str(Winsock1.State))
End If

End Sub

Sub WaitFor(ResponseCode As String)

Start = Timer ' Необходимо чтобы не зациклиться


While Len(Response) = 0
Tmr = Start - Timer

DoEvents 'Чтобы программа могла реагировать на другие события во время выполнения цикла

If Tmr > 50 Then ' Время в секундах для ожидания
MsgBox "Ошибка SMTP сервера", 64, "Ошибка"
Exit Sub
End If

Wend

While Left(Response, 3) <> ResponseCode

DoEvents 'Чтобы программа могла реагировать на другие события во время выполнения цикла

If Tmr > 50 Then
MsgBox "Ошибка SMTP сервера: " + ResponseCode + " отклик " + Response, 64, "Ошибка"
Exit Sub
End If

Wend

Response = "" 'отсылаем пустой отклик
End Sub

Private Sub Command1_Click()

SendEmail EmailServer.Text, FromName.Text, _
FromEmailAddress.Text, ToEmailAddress.Text, _
ToEmailAddress.Text, EmailSubject.Text, _
EmailBodyOfMessage.Text
'MsgBox ("Письмо отослано")
StatusTxt.Caption = "Письмо отослано"
StatusTxt.Refresh
Beep

Close
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

Winsock1.GetData Response
End Sub

[Alexanbar]

Методов авторизации несколько.
В простейшем случае (метод логин) нужно после подключения к серверу:

1) Winsock1.SendData "EHLO ETOYA" & vbCrLf

2) Winsock1.SendData "AUTH LOGIN" & vbCrLf

3)Winsock1.SendData AsciiToBase64(User) & vbCrLf

4)Winsock1.SendData AsciiToBase64(Password) & vbCrLf

Естественно, после каждой команды нужно ждать ответа сервера

[bvv70]

Спасибо. Но вот только

AsciiToBase64

это что?

[tyomitch]

Это функция base64-кодирования.

[bvv70]

Вот что я добавил:

Код: Выделить всё

Const Table As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
Function GetDec(Bin As String) As Long
If InStr(1, Bin, "=") Then GetDec = 64: Exit Function
If InStr(1, Bin, " ") Then GetDec = 256: Exit Function
Dim Cnt As Integer
Cnt = Len(Bin) - 1
For t = 1 To Len(Bin)
If Mid(Bin, t, 1) = 1 Then
GetDec = GetDec + (2 ^ Cnt)
End If
Cnt = Cnt - 1
Next
End Function

Function GetBin(Dec As Single, cFormat As Integer) As String
Dim sFormat As String
sFormat = String(cFormat, "0")
If Dec = 64 Then GetBin = "00000 ": Exit Function
If Dec = 0 Then GetBin = sFormat: Exit Function
Do While Dec >= 1
Dec = Int(Dec) / 2
If Dec = Int(Dec) Then
GetBin = 0 & GetBin
Else
GetBin = 1 & GetBin
End If
Loop
GetBin = Format$(GetBin, sFormat)
End Function

Function AsciiToBase64(sSource As String) As String
Dim Bin As String, Pos As Integer
For t = 1 To Len(sSource) Step 3
Bin = ""
For l = t To t + 2
If l > Len(sSource) Then
Bin = Bin & "0000000="
Else
Bin = Bin & GetBin(Asc(Mid$(sSource, l, 1)), 8)
End If
Next l
For m = 1 To Len(Bin) Step 6
Pos = GetDec(Mid$(Bin, m, 6))
AsciiToBase64 = AsciiToBase64 & Mid$(Table, Pos + 1, 1)
Next m
Next t
End Function


Если не трудно, помогите с кодом (ну то есть что касается передачи логина и пароля), не получается у меня что-то...

[Alexanbar]

Что именно не получается

[bvv70]

Я так понял, что после того, как соединение установлено нужно:

Код: Выделить всё

Winsock1.SendData "HELO ETOYA" & vbCrLf
Winsock1.SendData "AUTH LOGIN" & vbCrLf
Winsock1.SendData AsciiToBase64(User) & vbCrLf
Winsock1.SendData AsciiToBase64(Password) & vbCrLf

Как дождаться ответа с сервера? Что пишем после каждой строчки?

[Alexanbar]

Скорее всего, твоё

WaitFor(...)

после каждой строчки

[bvv70]

Пробовал со значением 250, зависает после соединения. Кстати, а почему в примере, которой я нашел значения разные (220, 250, 234)?

[tyomitch]

Потому что это код ответа, которого ждут.
Очень кривая система, кстати. Если сервер выдаст код ошибки, вся прога повиснет.

[Хакер]

Может тебе лучше сюда?

http://bbs.vbstreets.ru/viewtopic.php?t=15649

(правда CSocket - котоорый там юзается - оставляет желать лучшего)

[Alexanbar]

А зачем вообще использовать таймер?
Логичнее всю обработку перенести в Data_Arrival:

Код: Выделить всё

Public Sub Winsock_DataArrival _
    (ByVal bytesTotal As Long, Winsock1 As Object)

Dim strData$
Dim strResponseCode     As String

On Error Resume Next
Winsock1.GetData strData
If err.Number <> 0 Then
    err.Clear
   
    rqStat = ErrRq
    DoEvents
    Winsock1.Close
   
    Exit Sub
End If


strResponseCode = Left$(strData, 3)

Select Case strResponseCode
    Case "250", "220", "354", "334", "235"
       
        Select Case m_State
            Case MAIL_CONNECT, SMTP_HELO, SMTP_FROM, _
                SMTP_RCPTTO, SMTP_DATA, SMTP_DOT, wsk_CLOSE
           
                rqStat = OK
            Case MAIL_USER, MAIL_PASS, SMTP_AUTH
                rqStat = OK
        End Select
       
    Case Else
   
        '
        'If we are here server replied with
        'unacceptable respose code therefore we need
        'close connection and inform user about problem
        '
       
        Winsock1.Close
        '
        If Not m_State = MAIL_QUIT Then
            rqStat = ErrRq
           
            MsgBox "SMTP Error: " & strData, _
                    vbInformation, "SMTP Error"
           
        Else
            rqStat = OK
            'MsgBox "Message sent successfuly.", vbInformation
        End If
        '
       
End Select


End Sub

Public Sub WaitRq()

While rqStat = Wait

DoEvents
Wend
End Sub



Собственно авторизация:

Код: Выделить всё


.....

m_State = SMTP_AUTH 'MAIL_USER
   
    Panel1.Text = "Авторизация " '"Отправка имени пользователя"
   
    Winsock1.SendData "AUTH LOGIN" & vbCrLf
   
    rqStat = Wait
    WaitRq
    If rqStat = ErrRq Then
        Winsock1.Close
        SMTPConnect = False
        Exit Function
    End If
   
   
   
    m_State = SMTP_AUTH
   
    Panel1.Text = "Отправка имени пользователя"
   
   
    Winsock1.SendData AsciiToBase64(User) & vbCrLf
   
    rqStat = Wait
    WaitRq
    If rqStat = ErrRq Then
        Winsock1.Close
        SMTPConnect = False
        Exit Function
    End If
   
    m_State = SMTP_AUTH 'MAIL_PASS
   
    Panel1.Text = "Отправка пароля"
   
   
    p$ = AsciiToBase64(Password)
    Winsock1.SendData p & vbCrLf
   
    rqStat = Wait
    WaitRq
    If rqStat = ErrRq Then
        Winsock1.Close
        SMTPConnect = False
        Exit Function
    End If
.....


[bvv70]

Спасибо всем ответившим.

Может тебе лучше сюда?

http://bbs.vbstreets.ru/viewtopic.php?t=15649

(правда CSocket - котоорый там юзается - оставляет желать лучшего)

пример работает, но хотелось бы что-нибудь попроще - самому разобраться. Поэтому сейчас пробую по совету Alexanbar'a авторизацию выполнить.