Пример работы с SMTP

Материал из DRKB


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, Psock, NMsmtp;

type
  TForm1 = class(TForm)
    Memo: TRichEdit;
    Panel1: TPanel;
    SMTP: TNMSMTP;
    Panel2: TPanel;
    FromAddress: TEdit;
    predefined: TLabel;
    FromName: TEdit;
    Subject: TEdit;
    LocalProgram: TEdit;
    ReplyTo: TEdit;
    islog: TCheckBox;
    Host: TEdit;
    Port: TEdit;
    userid: TEdit;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    procedure CleanContext;
    procedure PerformConnection;
    procedure AddMessage(msg: string; color: Integer);
    procedure Log(inpt: string);
    procedure SetSMTP;
  public
    function SendEmail(_to, cc, bcc, Subject, body, attachment: string;
      HTMLFormat: Boolean): Boolean;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.SetSMTP;
begin
  SMTP.Host := Host.Text;
  SMTP.Port := StrToInt(Port.Text);
  SMTP.UserID := userid.Text;
end;

function GetEmailDateTime: string;
var
  tz: _time_Zone_information;
  s: string;
begin
  GetTimeZoneInformation(tz);
  if (tz.Bias * 100 div 60) < 1000 then
    s := Format(' -0%d', [tz.Bias * 100 div 60])
  else
    s := Format(' -%d', [tz.Bias * 100 div 60]);
  Result := FormatDateTime('ddd, dd mmm yyyy hh:nn:ss', Now) + s;
end;

procedure TForm1.CleanContext;
begin
  { set default values, some of them comes from "Setup" form }
  SMTP.PostMessage.FromAddress := FromAddress.Text;
  SMTP.PostMessage.FromName := FromName.Text;
  SMTP.PostMessage.ToAddress.Clear;
  SMTP.PostMessage.ToCarbonCopy.Clear;
  SMTP.PostMessage.ToBlindCarbonCopy.Clear;
  SMTP.PostMessage.Body.Clear;
  SMTP.PostMessage.Attachments.Clear;
  SMTP.PostMessage.Subject := Subject.Text;
  SMTP.PostMessage.LocalProgram := LocalProgram.Text;
  (*Mon, 27 Nov 2000 12:37:46 -0700*)
  SMTP.PostMessage.Date := GetEmailDateTime;
  SMTP.PostMessage.ReplyTo := ReplyTo.Text;
end;

procedure TForm1.Log(inpt: string);
var
  outf: TextFile;
begin
  { writing in the log file }
  if not islog.Checked then
    exit;
  AssignFile(outf, ChangeFileExt(ParamStr(0), '.log'));
  if FileExists(ChangeFileExt(ParamStr(0), '.log')) then
    Append(outf)
  else
    Rewrite(outf);
  WriteLn(outf, DateTimeToStr(Now) + '|' + inpt);
  CloseFile(outf);
end;

procedure TForm1.AddMessage(msg: string; color: Integer);
begin
  { showing in the memo field progress... }
  while memo.Lines.Count > 2000 do
    memo.Lines.Delete(0);
  memo.SelLength := 0;
  memo.SelStart := length(memo.Text);
  memo.SelAttributes.Color := Color;
  memo.SelText := #13#10 + DateTimeTostr(now) + ' ' + msg;
  memo.Perform($00B7, 0, 0);
  Application.ProcessMessages;
  if color <> clRed then
    log(DateTimeToStr(Now) + ' ' + msg)
  else
    log('Error: ' + DateTimeToStr(now) + ' ' + msg);
end;

procedure TForm1.PerformConnection;
begin
  while (not SMTP.Connected) do
  begin
    SetSMTP;
    AddMessage('Connecting to SMTP', clBlue);
    Application.ProcessMessages;
    try
      SMTP.Connect;
      AddMessage('No Errors', clBlue);
    except
      on E: Exception do
        AddMessage('Error conection: ' + E.Message, clBlue);
    end;
  end;
end;

function TForm1.SendEmail(_to, cc, bcc, Subject, body, attachment: string;
  HTMLFormat: Boolean): Boolean;
begin
  PerformConnection;
  Result := True;
  CleanContext;
  try
    if (attachment <> '') and (not Fileexists(attachment)) then
    begin
      AddMessage('Attachment is not ready yet (' + attachment + ') ', clNavy);
      Sleep(300);
      Result := False;
      exit;
    end;
    SMTP.PostMessage.ToAddress.Text :=
      StringReplace(_to, ';', #13#10, [rfReplaceAll, rfIgnoreCase]);
    if cc <> '' then
      SMTP.PostMessage.ToCarbonCopy.Text :=
        StringReplace(cc, ';', #13#10, [rfReplaceAll, rfIgnoreCase]);
    if bcc <> '' then
      SMTP.PostMessage.ToBlindCarbonCopy.Text :=
        StringReplace(bcc, ';', #13#10, [rfReplaceAll, rfIgnoreCase]);
    if Subject <> '' then
      SMTP.PostMessage.Subject := Subject;
    if HTMLFormat then
      SMTP.SubType := mtPlain
    else
      SMTP.SubType := mtHtml;
    SMTP.PostMessage.Body.Text := Body;
    if attachment <> '' then
      SMTP.PostMessage.Attachments.Add(attachment);
    AddMessage('Sending to ' + _to, clGreen);
    SMTP.SendMail;
    AddMessage('Complete.' + #13#10, clGreen);
  except
    on E: SysUtils.Exception do
    begin
      AddMessage(E.Message, clRed);
      Result := False;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendEmail('somewhere@somedomain.ru', '', '', 'test', 'body', '', False);
end;

end.


А это форма для этого примера:

object Form1: TForm1
Left = 278
Top = 108
Width = 539
Height = 480
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Memo: TRichEdit
Left = 0
Top = 0
Width = 346
Height = 420
Align = alClient
Lines.Strings = ('Memo')
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Top = 420
Width = 531
Height = 33
Align = alBottom
Caption = 'Panel1'
TabOrder = 1
object Button1: TButton
Left = 440
Top = 8
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end
object Panel2: TPanel
Left = 346
Top = 0
Width = 185
Height = 420
Align = alRight
Caption = 'Panel2'
TabOrder = 2
object predefined: TLabel
Left = 8
Top = 8
Width = 87
Height = 13
Caption = 'predefined values:'
end
object FromAddress: TEdit
Left = 24
Top = 32
Width = 121
Height = 21
TabOrder = 0
Text = 'FromAddress'
end
object FromName: TEdit
Left = 24
Top = 56
Width = 121
Height = 21
TabOrder = 1
Text = 'FromName'
end
object Subject: TEdit
Left = 24
Top = 80
Width = 121
Height = 21
TabOrder = 2
Text = 'Subject'
end
object LocalProgram: TEdit
Left = 24
Top = 104
Width = 121
Height = 21
TabOrder = 3
Text = 'LocalProgram'
end
object ReplyTo: TEdit
Left = 24
Top = 128
Width = 121
Height = 21
TabOrder = 4
Text = 'ReplyTo'
end
object islog: TCheckBox
Left = 32
Top = 168
Width = 97
Height = 17
Caption = 'islog'
TabOrder = 5
end
object Host: TEdit
Left = 24
Top = 240
Width = 121
Height = 21
TabOrder = 6
Text = 'Host'
end
object Port: TEdit
Left = 24
Top = 264
Width = 121
Height = 21
TabOrder = 7
Text = 'Port'
end
object userid: TEdit
Left = 24
Top = 288
Width = 121
Height = 21
TabOrder = 8
Text = 'userid'
end
end
object SMTP: TNMSMTP
Port = 25
ReportLevel = 0
EncodeType = uuMime
ClearParams = True
SubType = mtPlain
Charset = 'us-ascii'
Left = 296
Top = 32
end
end


Author: Vit
Source: Vingrad.ru http://forum.vingrad.ru
ID: 03399



В следующем примере E-mail отправляется автоматически сразу после нажатия кнопки.

ЗАМЕЧАНИЕ: Вам потребуется компонент 'TNMSMTP'. Этот компонент входит в поставляется с Delphi 4 и 5 и его можно найти на закладке 'Fastnet'.

procedure TForm1.Button1Click(Sender: TObject);
begin
  NMSMTP1.Host := 'smtp.mailserver.com';
  NMSMTP1.UserID := 'h.abdullah';
  NMSMTP1.Connect;
  NMSMTP1.PostMessage.FromAddress := 'hasan@excite.com';
  NMSMTP1.PostMessage.ToAddress.Text := 'someone@xmail.com';
  NMSMTP1.PostMessage.Body.Text := 'Текст письма';
  NMSMTP1.PostMessage.Subject := 'Тема письма';
  NMSMTP1.SendMail;
end;


Source: http://forum.sources.ru
ID: 03400