Пример работы с 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