unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, Socket_Misk, ExtCtrls, Menus;

type
  TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    memoLog: TMemo;
    Panel1: TPanel;
    Label2: TLabel;
    edFrom: TEdit;
    Label1: TLabel;
    memoRecipients: TMemo;
    Label3: TLabel;
    edSubject: TEdit;
    Label4: TLabel;
    memoBody: TMemo;
    Label5: TLabel;
    edSMTPHost: TEdit;
    GroupBox1: TGroupBox;
    lbLogin: TLabel;
    lbPassword: TLabel;
    edLogin: TEdit;
    edPassword: TEdit;
    cbAuth: TCheckBox;
    btnMail: TButton;
    btnClose: TButton;
    Splitter1: TSplitter;
    SaveDialog1: TSaveDialog;
    MainMenu1: TMainMenu;
    N1: TMenuItem;
    N2: TMenuItem;
    N3: TMenuItem;
    N4: TMenuItem;
    procedure btnMailClick(Sender: TObject);
    procedure cbAuthClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure N4Click(Sender: TObject);
  private
    { Private declarations }
  //вывод лога SMTP-сессии
  Procedure WMSMTP(var Msg:TMessage); message WM_SMTP;
  //обработка ответа SMTP-сервера
  Function ProcessSMTPResult(ReceivedResult,//полученный ответ
                            ExpectResult:Integer;//ожидаемый ответ
                            CloseSMTPSession:Boolean)//закрываем сессию или нет
                            :Boolean;
  //обработаем процесс передачи команд SMTP-серверу
  Function ProcessSMTPWrite(SMTPWriting:Boolean):Boolean;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses Base64Unit;

{$R *.DFM}
Procedure TForm1.WMSMTP(var Msg:TMessage);
Var
CS:String;
Begin {WMSMTP}
CS:='';
Case Msg.WParam Of
0:CS:='C:>';
1:CS:='S:>';
End;
memoLog.Text:=memoLog.Text+CS+String(Msg.lParam);
Application.ProcessMessages;
inherited;
End;  {WMSMTP}

Function TForm1.ProcessSMTPWrite(SMTPWriting:Boolean):Boolean;
Begin
If SMTPWriting Then
Begin
Result:=True;
StatusBar1.Panels[0].Text:='Готово ...';
End
Else
Begin
Result:=False;
StatusBar1.Panels[0].Text:='Сервер не отвечает...';
End;
Application.ProcessMessages;
End;

Function TForm1.ProcessSMTPResult(ReceivedResult,ExpectResult:Integer;
                                  CloseSMTPSession:Boolean):Boolean;
Begin
If ReceivedResult=0 Then
Begin {ошибка чтения из сокета}
//ошибка сокета, все процедуры закрытия и освобождения сокета уже были
//сделаны в функции ReadFromSocket модуля Socket_Misk.pas
StatusBar1.Panels[0].Text:='Ошибка чтения из сокета...';
Result:=False;
End   {ошибка чтения из сокета}
Else
Begin {сокет прочитан успешно}
//полученный результат не соответствует ожидаемому
If Not(ReceivedResult=ExpectResult) Then
Begin {If Not}
If CloseSMTPSession Then
//несовпадение результатов - критическая ошибка и завершение сессии обязательно
Begin {CloseSMTPSession}
//пытаемся передать команду завершения SMTP-сессии
If WriteToSocket('QUIT') Then
ReadFromSocket;
CleanUp;
StatusBar1.Panels[0].Text:='Ошибка SMTP-сессии...';
End  {CloseSMTPSession}
Else
Begin {Else CloseSMTPSession}
//несовпадение результатов - ошибка не критическая, закрывать сесиию не будем
StatusBar1.Panels[0].Text:='Ожидался другой ответ сервера...';
End;{Else CloseSMTPSession}
Result:=False;
End {If Not}
Else
Begin {коды совпадают}
//все в порядке - коды совпадают
StatusBar1.Panels[0].Text:='Готово...';
Result:=True;
End;  {коды совпадают}
End; {сокет прочитан успешно}
Application.ProcessMessages;
End;

procedure TForm1.btnMailClick(Sender: TObject);
Var
N:Integer;
begin
If edSMTPHost.Text='' Then
Begin
MessageBox(Handle,'SMTP-сервер надо указывать обязательно!','Ошибка!',MB_OK Or MB_ICONERROR);
edSMTPHost.SetFocus;
Exit;
End;

If edFrom.Text='' Then
Begin
MessageBox(Handle,'Поле FROM: заполнять обязательно!','Ошибка!',MB_OK Or MB_ICONERROR);
edFrom.SetFocus;
Exit;
End;

If memoRecipients.Text='' Then
Begin
MessageBox(Handle,'Поле TO: заполнять обязательно!','Ошибка!',MB_OK Or MB_ICONERROR);
memoRecipients.SetFocus;
Exit;
End;

memoLog.Lines.Clear;
StatusBar1.Panels[0].Text:='Инициализирую сокет...';
If Not InitSocket Then
Begin
StatusBar1.Panels[0].Text:='Ошибка инициализации сокета...';
Application.ProcessMessages;
Exit;
End;
//=================================Connect&OPEN=================================
//Запрос
StatusBar1.Panels[0].Text:='Соединяюсь с сервером...';
{SMTP port = 25}
If Not ConnectHost(25,edSMTPHost.Text) Then
Begin
StatusBar1.Panels[0].Text:='Ошибка соединения с сервером...';
Application.ProcessMessages;
Exit;
End;
StatusBar1.Panels[0].Text:='Готово...';
//Ответ ожидается 220 - OK RFC 821
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),220,True) Then
Exit;

//=================================EHLO=========================================
//Запрос EHLO для SMTP Service Extension - ESMTP
//RFC 1854, 2197
//Преимущество конвейерной переадачи данных (pipelining) ESMTP перед
//SMTP (RFC 821) использовать не будем, для нас самое главное - авторизация доступа
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('EHLO SMTPSample')) Then
//If Not ProcessSMTPWrite(WriteToSocket('HELO SMTPSample')) Then
Exit;

//Ответ 250 RFC 1854, весь конвейер (pipelining) не обрабатывем,
//берем только первый ответ
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),250,True) Then
Exit;

//Если авторизация SMTP-сервера активирована
If cbAuth.Checked Then
Begin {cbAuth.Checked Login}
//===============================AUTH LOGIN=====================================
//авторизация SMTP-сессии команда AUTH LOGIN,
//RFC 2554
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('AUTH LOGIN')) Then
Exit;

//ожидаемый код ответа 334 (RFC 2554) и base64 кодированный запрос VXNlcm5hbWU6 (User:),
// в случае ошибки (см. ниже) сессию не прекращаем,
//(аргумент CloseSMTPSession функции ProcessSMTPResult равен False)
//т.к. возможно, что на сервере не включена авторизации или включен механизм
//авторизации, отличный от LOGIN PLAIN
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),334,False) Then
//коды ошибок (RFC 2554) не обрабатываем
//432 A password transition is needed
//454 Temporary authentication failure
//501 Server cannot BASE64 decode the argument
//503 Any further AUTH commands after a successful AUTH command completes
//504 Requested authentication mechanism is not supported
//530 Authentication required
//534 Authentication mechanism is too weak
//535 Authorization failed
//538 Encryption required for requested authentication mechanism
//553 Authorization failed or you have have reached maximum messages in a hour (flock1.newmail.ru ESMTP)

//отключаем авторизацию
cbAuth.Checked:=False;
End;{cbAuth.Checked Login}
//если все в порядке сервер отсылает код 334

//=================================User=========================================
//Если авторизация SMTP-сервера активирована
If cbAuth.Checked Then
Begin {cbAuth.Checked User}
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
//отсылаем base64-кодированный Login
If Not ProcessSMTPWrite(WriteToSocket(StrToStrBase64(edLogin.Text))) Then
Exit;

StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
//ожидаемый код ответа 334 (RFC 2554) и base64-кодированный запрос UGFzc3dvcmQ6 (Password:)
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),334,False) Then
//возможные ошибки не обрабатываем и отключаем авторизацию
cbAuth.Checked:=False;
End;  {cbAuth.Checked User}
//================================Password======================================
//Если авторизация SMTP-сервера активирована
If cbAuth.Checked Then
Begin {cbAuth.Checked Password}
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
//отсылаем base64-кодированный Password
If Not ProcessSMTPWrite(WriteToSocket(StrToStrBase64(edPassword.Text))) Then
Exit;

StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
//ожидаемый код ответа 235,
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),235,True) Then
//в нашем случае механизм авторизации сработал успешно,
//но сервер не опознал пользователя, - завершаем SMTP-сессию
//(аргумент CloseSMTPSession функции ProcessSMTPResult равен True)
Exit;
End;  {cbAuth.Checked Password}

//=================================MAIL FROM:===================================
//посылаем команду MAIL FROM: (RFC 821)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('MAIL FROM: <'+edFrom.Text+'>')) Then
Exit;

//ожидаемый код ответа 250 (RFC 821),
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),250,True) Then
Exit;

//===================================RCPT TO:===================================
//посылаем команду RCPT TO: (RFC 821)
For N:=0 To memoRecipients.Lines.Count-1 Do
Begin {For N}
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('RCPT TO: <'+memoRecipients.Lines.Strings[N]+'>'))
Then
Exit;

StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),250,True) Then
Exit;

End;  {For N}
(*
//ожидаемый код ответа 250 (RFC 821),
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),250,True) Then
Exit;
*)

//===================================DATA=======================================
//Отсылаем команду DATA (RFC 821)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('DATA')) Then
Exit;

//ожидаемый код ответа 354 (RFC 821),
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),354,True) Then
Exit;
//Отсылаем тело сообщения (заголовок письма + тело письма)
//заголовок RFC (822) From: (обязательное поле)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not WriteToSocket('From: '+edFrom.Text) Then
Begin
StatusBar1.Panels[0].Text:='Сервер не отвечает...';
Application.ProcessMessages;
Exit;
End;
StatusBar1.Panels[0].Text:='Готово ...';

//заголовок RFC (822) Date:  (обязательное поле)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('Date: '+InternetDate)) Then
Exit;

//заголовок RFC (822) To:  (обязательное поле)
For N:=0 To memoRecipients.Lines.Count-1 Do
Begin {For N}
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('To: <'+memoRecipients.Lines.Strings[N]+'>')) Then
Exit;
End;  {For N}

//заголовок RFC (822) Subject:  (не обязательное поле)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('Subject: '+edSubject.Text)) Then
Exit;

//заголовок RFC (822) Content-Type:  (не обязательное поле)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('Content-Type: text/plain; charset=windows-1251')) Then
Exit;

//отделяем пустой строкой заголовок письма от его тела
//(обязательная инструкция RFC 821)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('')) Then
Exit;
//тело письма (RFC 821)
For N:=0 To memoBody.Lines.Count-1 Do
Begin {For N}
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket(memoBody.Lines.Strings[N])) Then
Exit;
End;  {For N}
//завершаем точкой конец сообщения
//(обязательная инструкция RFC 821)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('.')) Then
Exit;

//ожидаемый код ответа 250 (RFC 821),
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),250,True) Then
Exit;

//======================================QUIT====================================
//отсылаем команду QUIT (RFC 821)
StatusBar1.Panels[0].Text:='Посылаю запрос на сервер ...';
If Not ProcessSMTPWrite(WriteToSocket('QUIT')) Then
Exit;

//ожидаемый код ответа 221 (RFC 821),
StatusBar1.Panels[0].Text:='Ожидаю ответ сервера ...';
If Not ProcessSMTPResult(SocketResult(ReadFromSocket),221,True) Then
Exit;

ShowMessage('OK!');

end;

procedure TForm1.cbAuthClick(Sender: TObject);
begin
lbLogin.Enabled:=cbAuth.Checked;
lbPassword.Enabled:=cbAuth.Checked;
edLogin.Enabled:=cbAuth.Checked;
edPassword.Enabled:=cbAuth.Checked;
end;

procedure TForm1.btnCloseClick(Sender: TObject);
begin
Close;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
MainFormHandle:=Handle;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
//Cleanup;
end;

procedure TForm1.N4Click(Sender: TObject);
begin
If Not SaveDialog1.Execute Then Exit;
memoLog.Lines.SaveToFile(SaveDialog1.FileName);
end;

end.
