|
|
|
Winsock+send mail+authorization
|
|||
|---|---|---|---|
|
#18+
Помогите пожалуйста с SMTP авторизацией. Private Sub btSend_Click() ' Dim i As Integer ' 'prepare attachments ' m_strEncodedFiles = "" For i = 0 To lstAttachments.ListCount - 1 lstAttachments.ListIndex = i m_strEncodedFiles = m_strEncodedFiles & _ UUEncodeFile(lstAttachments.Text) & vbCrLf Next i ' Winsock1.Connect Trim$(txtHost), 25 m_State = MAIL_CONNECT ' End Sub Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) Dim strServerResponse As String Dim strResponseCode As String Dim strDataToSend As String ' 'Retrive data from winsock buffer ' Winsock1.GetData strServerResponse ' Debug.Print strServerResponse ' 'Get server response code (first three symbols) ' strResponseCode = Left(strServerResponse, 3) ' 'Only these three codes tell us that previous 'command accepted successfully and we can go on ' If strResponseCode = "250" Or _ strResponseCode = "220" Or _ strResponseCode = "354" Then Select Case m_State Case MAIL_CONNECT 'Change current state of the session m_State = MAIL_HELO ' 'Remove blank spaces strDataToSend = Trim$(txtSender) ' 'Retrieve mailbox name from e-mail address strDataToSend = Left$(strDataToSend, _ InStr(1, strDataToSend, "@") - 1) 'Send HELO command to the server Winsock1.SendData "HELO " & strDataToSend & vbCrLf ' Debug.Print "HELO " & strDataToSend ' Case MAIL_HELO ' 'Change current state of the session m_State = MAIL_FROM ' 'Send MAIL FROM command to the server Winsock1.SendData "MAIL FROM:" & Trim$(txtSender) & vbCrLf ' Debug.Print "MAIL FROM:" & Trim$(txtSender) ' Case MAIL_FROM ' 'Change current state of the session m_State = MAIL_RCPTTO ' 'Send RCPT TO command to the server Winsock1.SendData "RCPT TO:" & Trim$(txtRecipient) & vbCrLf ' Debug.Print "RCPT TO:" & Trim$(txtRecipient) ' Case MAIL_RCPTTO ' 'Change current state of the session m_State = MAIL_DATA ' 'Send DATA command to the server Winsock1.SendData "DATA" & vbCrLf ' Debug.Print "DATA" ' Case MAIL_DATA ' 'Change current state of the session m_State = MAIL_DOT ' 'So now we are sending a message body 'Each line of text must be completed with 'linefeed symbol (Chr$(10) or vbLf) not with vbCrLf ' 'Send Subject line Winsock1.SendData "Subject:" & txtSubject & vbLf & vbCrLf ' Debug.Print "Subject:" & txtSubject ' Dim varLines As Variant Dim varLine As Variant Dim strMessage As String ' 'Add atacchments strMessage = txtMessage & vbCrLf & vbCrLf & m_strEncodedFiles 'clear memory m_strEncodedFiles = "" 'Parse message to get lines (for VB6 only) varLines = Split(strMessage, vbCrLf) 'clear memory strMessage = "" ' 'Send each line of the message For Each varLine In varLines Winsock1.SendData CStr(varLine) & vbLf ' Debug.Print CStr(varLine) Next ' 'Send a dot symbol to inform server 'that sending of message comleted Winsock1.SendData "." & vbCrLf ' Debug.Print "." ' Case MAIL_DOT 'Change current state of the session m_State = MAIL_QUIT ' 'Send QUIT command to the server Winsock1.SendData "QUIT" & vbCrLf ' Debug.Print "QUIT" Case MAIL_QUIT ' 'Close connection Winsock1.Close ' End Select 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 MsgBox "Ошибка SMTP: " & strServerResponse, _ vbExclamation, "Ошибка SMTP" Else MsgBox "сообщение успешно отправлено.", vbInformation End If ' End If End Sub ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 23.05.2006, 09:51 |
|
||
|
Winsock+send mail+authorization
|
|||
|---|---|---|---|
|
#18+
Сам нашел решение, может кому интересно будет:-) Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) Dim strServerResponse As String Dim strResponseCode As String Dim strDataToSend As String ' 'Retrive data from winsock buffer ' Winsock1.GetData strServerResponse MsgBox (m_State & "**" & strServerResponse) ' Debug.Print strServerResponse ' 'Get server response code (first three symbols) ' strResponseCode = Left(strServerResponse, 3) ' 'Only these three codes tell us that previous 'command accepted successfully and we can go on ' If strResponseCode = "250" Or _ strResponseCode = "220" Or _ strResponseCode = "334" Or _ strResponseCode = "354" Then Select Case m_State Case MAIL_CONNECT 'Change current state of the session m_State = MAIL_HELO ' 'Remove blank spaces strDataToSend = Trim$(txtSender) ' 'Retrieve mailbox name from e-mail address strDataToSend = Left$(strDataToSend, _ InStr(1, strDataToSend, "@") - 1) 'Send HELO command to the server Winsock1.SendData "HELO " & strDataToSend & vbCrLf ' Debug.Print "HELO " & strDataToSend ' Case MAIL_HELO ' 'Change current state of the session m_State = MAIL_FROM ' 'Send MAIL FROM command to the server Winsock1.SendData "AUTH LOGIN " & vbCrLf Winsock1.SendData Base64Encode("login") & vbCrLf Winsock1.SendData Base64Encode("password") & vbCrLf Winsock1.SendData "MAIL FROM:" & Trim$(txtSender) & vbCrLf ' Debug.Print "MAIL FROM:" & Trim$(txtSender) ' Case MAIL_FROM ' 'Change current state of the session m_State = MAIL_RCPTTO ' 'Send RCPT TO command to the server Winsock1.SendData "RCPT TO:" & Trim$(txtRecipient) & vbCrLf ' Debug.Print "RCPT TO:" & Trim$(txtRecipient) ' Case MAIL_RCPTTO ' 'Change current state of the session m_State = MAIL_DATA ' 'Send DATA command to the server Winsock1.SendData "DATA" & vbCrLf ' Debug.Print "DATA" ' Case MAIL_DATA ' 'Change current state of the session m_State = MAIL_DOT ' 'So now we are sending a message body 'Each line of text must be completed with 'linefeed symbol (Chr$(10) or vbLf) not with vbCrLf ' 'Send Subject line Winsock1.SendData "Subject:" & txtSubject & vbLf & vbCrLf ' Debug.Print "Subject:" & txtSubject ' Dim varLines As Variant Dim varLine As Variant Dim strMessage As String ' 'Add atacchments strMessage = txtMessage & vbCrLf & vbCrLf & m_strEncodedFiles 'clear memory m_strEncodedFiles = "" 'Parse message to get lines (for VB6 only) varLines = Split(strMessage, vbCrLf) 'clear memory strMessage = "" ' 'Send each line of the message For Each varLine In varLines Winsock1.SendData CStr(varLine) & vbLf ' Debug.Print CStr(varLine) Next ' 'Send a dot symbol to inform server 'that sending of message comleted Winsock1.SendData "." & vbCrLf ' Debug.Print "." ' Case MAIL_DOT 'Change current state of the session m_State = MAIL_QUIT ' 'Send QUIT command to the server Winsock1.SendData "QUIT" & vbCrLf ' Debug.Print "QUIT" Case MAIL_QUIT ' 'Close connection Winsock1.Close ' End Select 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 MsgBox "Îøèáêà SMTP: " & strServerResponse, _ vbExclamation, "Îøèáêà SMTP" Else MsgBox "Áîðäåðî óñïåøíî îòïðàâëåíî.", vbInformation End If ' End If End Sub Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) MsgBox "Îøèáêà ñîåäèíåíèÿ ¹ " & Number & vbCrLf & _ Description, vbExclamation, "Îøèáêà ñîåäèíåíèÿ" Winsock1.Close End Sub Private Function Base64Encode(ByVal inData) As String Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Dim cOut, sOut, i 'For each group of 3 bytes For i = 1 To Len(inData) Step 3 Dim nGroup, pOut, sGroup 'Create one long from this 3 bytes. nGroup = &H10000 * Asc(Mid(inData, i, 1)) + &H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1)) 'Oct splits the long To 8 groups with 3 bits nGroup = Oct(nGroup) 'Add leading zeros nGroup = String(8 - Len(nGroup), "0") & nGroup 'Convert To base64 pOut = Mid(Base64, CLng("&o" & Mid(nGroup, 1, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 3, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 5, 2)) + 1, 1) + _ Mid(Base64, CLng("&o" & Mid(nGroup, 7, 2)) + 1, 1) 'Add the part To OutPut string sOut = sOut + pOut 'Add a new line For Each 76 chars In dest (76*3/4 = 57) 'If (I + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf Next Select Case Len(inData) Mod 3 Case 1 '8 bit final sOut = Left(sOut, Len(sOut) - 2) + "==" Case 2 '16 bit final sOut = Left(sOut, Len(sOut) - 1) + "=" End Select Base64Encode = sOut End Function Private Function MyASC(ByVal OneChar) As Integer If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar) End Function ... |
|||
|
:
Нравится:
Не нравится:
|
|||
| 23.05.2006, 14:25 |
|
||
|
|

start [/forum/topic.php?fid=60&tid=2165824]: |
0ms |
get settings: |
8ms |
get forum list: |
9ms |
check forum access: |
2ms |
check topic access: |
2ms |
track hit: |
153ms |
get topic data: |
7ms |
get forum data: |
1ms |
get page messages: |
18ms |
get tp. blocked users: |
1ms |
| others: | 245ms |
| total: | 446ms |

| 0 / 0 |
