| Вопрос: Отправка e-mail сообщений | Добавлено: 13.02.09 11:51 |
Автор вопроса:  Andrey
|
|
Народ, помогите пожалуйста с программной отправкой меил сообщений без каких либо вложений - просто текст. Нужен пример програмного кода.
Заранее спасибо! :) |
| Ответы | Всего ответов: 2 |
|
Номер ответа: 1 Автор ответа:  VerhoLom Вопросов: 20 Ответов: 285 |
Профиль | | #1 | Добавлено: 15.02.09 15:46 |
|
Если есть знание ассемблера (хоть чуть-чуть), то это то, что надо:
http://wasm.ru/print.php?article=1016002 http://wasm.ru/baixado.php?mode=src&id=105 Если же нету, то внимательно читайте текст статьи и разбирайте код примера - там описано, какие строки надо посылать почтовому серверу, используя соккеты (можно и винсок контрол) |
||
|
Номер ответа: 2 Автор ответа: Andrey Вопросов: 1 Ответов: 8 |
Профиль | | #2 | Добавлено: 16.02.09 16:09 |
|
Вот, нашел такой код:
Option Explicit Dim buff As String Dim step As Integer Dim SMTPServer As String Dim log As String Private Sub Form_Load() SB1.Panels(1).Text = Time End Sub Private Sub SB1_PanelClick(ByVal Panel As MSComctlLib.Panel) Form2.Show Form2.txtLog.Text = log End Sub Private Sub Timer1_Timer() SB1.Panels(1).Text = Time End Sub Private Sub btnSend_Click() Dim ws As New IWshRuntimeLibrary.WshShell Dim wse As IWshRuntimeLibrary.WshExec Dim domain As String, answer As String Dim rexp As New RegExp, m As Match, mc As MatchCollection 'проверяем входные данные rexp.Pattern = "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*" rexp.IgnoreCase = True rexp.Global = True If Not rexp.Test(txtFrom.Text) Then MsgBox "Укажите корректный адрес отправителя!" Exit Sub End If If Not rexp.Test(txtTo.Text) Then MsgBox "Укажите корректный адрес получателя!" Exit Sub End If If txtSubject.Text = "" Then MsgBox "Поле Subject не может быть пустым!" Exit Sub End If If txtBody.Text = "" Then MsgBox "Поле Body не может быть пустым!" Exit Sub End If 'определяем адрес почтового сервера SB1.Panels(2).Text = "Определяем почтовый сервер получателя..." log = Now & " > " & SB1.Panels(2).Text & vbCrLf domain = Split(txtTo, "@"  (1)
Set wse = ws.Exec("nslookup -querytype=MX " & domain) SMTPServer = ""  o
answer = wse.StdOut.ReadLine If InStr(1, answer, "exchanger", vbTextCompare) > 0 Then SMTPServer = LTrim(Split(Mid(answer, InStr(1, answer, "exchanger", vbTextCompare)), "=" (1))
Exit Do End If Loop Until wse.StdOut.AtEndOfStream If SMTPServer <> "" Then SB1.Panels(2).Text = "Почтовый сервер получателя определен!" log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf 'посылаем письмо SendMsg txtFrom.Text, txtTo.Text, txtBody.Text, SMTPServer End Sub Sub SendMsg(from As String, txtTo As String, msg As String, host As String) WS1.Close WS1.RemoteHost = host WS1.RemotePort = 25 buff = "" SB1.Panels(2).Text = "Соединяемся с сервером..." log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf step = 0: WS1.Connect End Sub Private Sub WS1_DataArrival(ByVal bytesTotal As Long) buff = String(bytesTotal, " "
WS1.GetData buff Select Case step Case 0 'connect 220 If Mid(buff, 1, 3) = "220" Then step = 1: WS1.SendData "HELO " & SMTPServer & vbCrLf SB1.Panels(2).Text = "Соединение установлено!" Else SB1.Panels(2).Text = "Error! " & buff: WS1.Close End If log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf Case 1 'send HELO 250 If Mid(buff, 1, 3) = "250" Then SB1.Panels(2).Text = "Начинаем отправку письма... передача ОТ КОГО" step = 2: WS1.SendData "MAIL FROM:<" & txtFrom.Text & ">" & vbCrLf Else SB1.Panels(2).Text = "Error! " & buff: WS1.Close End If log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf Case 2 'send MAILFROM 250 If Mid(buff, 1, 3) = "250" Then SB1.Panels(2).Text = "Продолжаем отправку письма... передача КОМУ" step = 3: WS1.SendData "RCPT TO:<" & txtTo.Text & ">" & vbCrLf Else SB1.Panels(2).Text = "Error! " & buff: WS1.Close End If log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf Case 3 'send RCPT TO 250 If Mid(buff, 1, 3) = "250" Then SB1.Panels(2).Text = "Продолжаем отправку письма... заголовок ДАННЫЕ" step = 4: WS1.SendData " ATA" & vbCrLf
Else SB1.Panels(2).Text = "Error! " & buff: WS1.Close End If log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf Case 4 'send DATA 354 If Mid(buff, 1, 3) = "354" Then SB1.Panels(2).Text = "Продолжаем отправку письма... собственно ПИСЬМО" step = 5: WS1.SendData _ "From: " & txtFrom.Text & vbCrLf & _ "To: " & txtTo.Text & vbCrLf & _ "Subject: " & txtSubject.Text & vbCrLf & _ "Content-type:text/plain; charset=windows-1251" & vbCrLf & vbCrLf & _ txtBody.Text & _ vbCrLf & "." & vbCrLf Else SB1.Panels(2).Text = "Error! " & buff: WS1.Close End If log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf Case 5 'send from+to+Content-type:text/plain;charset=windows-1251+subject + body + vbcrlf + . + vbcrlf 250 If Mid(buff, 1, 3) = "250" Then SB1.Panels(2).Text = "Завершаем отправку письма... отсоединение" WS1.Close SB1.Panels(2).Text = "Письмо отправлено!" End If log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf End Select End Sub Private Sub WS1_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) WS1.Close SB1.Panels(2).Text = "Error WinSock! " & Number log = log & Now & " > " & SB1.Panels(2).Text & vbCrLf End Sub Он полностью работоспособен, но отправляет письма только на сервера без SMTP аутентификации. Как осуществить SMTP авторизацию? |
||
Страница: 1 |