Delphi World - Пример работы с SMTP
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Пример работы с SMTP

Автор: 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
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования