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

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
Category:Связь
Category:Электронная почта