Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

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

01.01.2007
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('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

Автор: Vit

Взято с Vingrad.ru https://forum.vingrad.ru


В следующем примере 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;

Взято из https://forum.sources.ru