Автор: Vit
WEB-сайт: http://forum.vingrad.ru

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;
{set default values, some of them comes from "Setup" form}
begin
  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('vit@vingrad.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