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

Использование SMTP Relay Server

01.01.2007

Использование SMTP Relay Server - отсылка письма напрямую минуя любые промежуточные сервера (пример взят из библиотеки Indy). Для отсылки письма с использованием компонентов Indy. Пример для Delphi 7 (скорее всего будет работать и в Delphi 6), для Kylix 3 нужны небольшие исправления для перевода в CLX приложение (сама функциональность та же).

Пример модуля:

unit fMain;
 

 
 
interface
 
uses
 
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
 
IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP, IdComponent,
 
IdUDPBase, IdUDPClient, IdDNSResolver, IdBaseComponent, IdMessage,
 
StdCtrls, ExtCtrls, ComCtrls, IdAntiFreezeBase, IdAntiFreeze;
 
type
 
TfrmMain = class(TForm)
   
IdMessage: TIdMessage;
   
IdDNSResolver: TIdDNSResolver;
   
IdSMTP: TIdSMTP;
    Label1
: TLabel;
    sbMain
: TStatusBar;
    Label2
: TLabel;
    edtDNS
: TEdit;
    Label3
: TLabel;
    Label4
: TLabel;
    edtSender
: TEdit;
    Label5
: TLabel;
    edtRecipient
: TEdit;
    Label6
: TLabel;
    edtSubject
: TEdit;
    Label7
: TLabel;
    mmoMessageText
: TMemo;
    btnSendMail
: TButton;
    btnExit
: TButton;
   
IdAntiFreeze: TIdAntiFreeze;
    Label8
: TLabel;
    edtTimeOut
: TEdit;
    Label9
: TLabel;
    Label10
: TLabel;
    procedure btnExitClick
(Sender: TObject);
    procedure btnSendMailClick
(Sender: TObject);
 
public
  fMailServers
: TStringList;
 
Function PadZero(s:String):String;
 
Function GetMailServers:Boolean;
 
Function ValidData : Boolean;
 
Procedure SendMail; OverLoad;
 
Function SendMail(aHost : String):Boolean; OverLoad;
 
Procedure LockControls;
  procedure
UnlockControls;
 
Procedure Msg(aMessage:String);
 
end;
 
var
  frmMain
: TfrmMain;
 
implementation
 
{$R *.DFM}
 
procedure
TfrmMain.btnExitClick(Sender: TObject);
begin
application
.terminate;
end;
 
procedure
TfrmMain.btnSendMailClick(Sender: TObject);
begin
Msg('');
LockControls;
if ValidData then SendMail;
UnlockControls;
Msg('');
end;
 
function TfrmMain.GetMailServers: Boolean;
var
  i
,x : integer;
 
LDomainPart : String;
 
LMXRecord : TMXRecord;
begin
if not assigned(fmailServers) then fMailServers := TStringList.Create;
fmailServers
.clear;
 
Result := true;
 
with IdDNSResolver do
 
begin
 
QueryResult.Clear;
 
QueryRecords := [qtMX];
 
Msg('Setting up DNS query parameters');
 
Host := edtDNS.text;
 
ReceiveTimeout := StrToInt(edtTimeOut.text);
 
// Extract the domain part from recipient email address
 
LDomainPart := copy(edtRecipient.text,pos('@',edtRecipient.text)+1,length(edtRecipient.text));
 
// the domain name to resolve
 
try
 
Msg('Resolving DNS');
 
Resolve(LDomainPart);
 
if QueryResult.Count > 0 then
   
begin
     
for i := 0 to QueryResult.Count - 1 do
       
begin
       
LMXRecord := TMXRecord(QueryResult.Items[i]);
        fMailServers
.Append(PadZero(IntToStr(LMXRecord.Preference)) + '=' + LMXRecord.ExchangeServer);
       
end;
   
// sort in order of priority and then remove extra data
    fMailServers
.Sorted := false;
   
for i := 0 to fMailServers.count - 1 do
     
begin
      x
:= pos('=',fMailServers.Strings[i]);
     
if x > 0 then fMailServers.Strings[i] :=
        copy
(fMailServers.Strings[i],x+1,length(fMailServers.Strings[i]));
     
end;
    fMailServers
.Sorted := true;
    fMailServers
.Duplicates := dupIgnore;
   
Result := true;
   
end
 
else
   
begin
   
Msg('No response from DNS server');
   
MessageDlg('There is no response from the DNS server !', mtInformation, [mbOK], 0);
   
Result := false;
   
end;
 
except
  on E
: Exception do
   
begin
   
Msg('Error resolving domain');
   
MessageDlg('Error resolving domain: ' + e.message, mtInformation, [mbOK], 0);
   
Result := false;
   
end;
 
end;
 
end;
end;
 
// Used in DNS preferance sorting
procedure
TfrmMain.LockControls;
var i : integer;
begin
edtDNS
.enabled := false;
edtSender
.enabled := false;
edtRecipient
.enabled := false;
edtSubject
.enabled := false;
mmoMessageText
.enabled := false;
btnExit
.enabled := false;
btnSendMail
.enabled := false;
end;
 
procedure
TfrmMain.UnlockControls;
begin
edtDNS
.enabled := true;
edtSender
.enabled := true;
edtRecipient
.enabled := true;
edtSubject
.enabled := true;
mmoMessageText
.enabled := true;
btnExit
.enabled := true;
btnSendMail
.enabled := true;
end;
 
 
function TfrmMain.PadZero(s: String): String;
begin
if length(s) < 2 then s := '0' + s;
Result := s;
end;
 
procedure
TfrmMain.SendMail;
var i : integer;
begin
if GetMailServers then
 
begin
 
with IdMessage do
   
begin
   
Msg('Assigning mail message properties');
   
From.Text := edtSender.text;
   
Sender.Text := edtSender.text;
   
Recipients.EMailAddresses := edtRecipient.text;
   
Subject := edtSubject.text;
   
Body := mmoMessageText.Lines;
   
end;
 
for i := 0 to fMailServers.count -1 do
   
begin
   
Msg('Attempting to send mail');
   
if SendMail(fMailServers.Strings[i]) then
     
begin
     
MessageDlg('Mail successfully sent and available for pickup by recipient !',
mtInformation
, [mbOK], 0);
     
Exit;
     
end;
   
end;
 
// if we are here then something went wrong .. ie there were no available servers to accept our mail!
 
MessageDlg('Could not send mail to remote server - please try again later.', mtInformation, [mbOK], 0);
 
end;
if assigned(fMailServers) then FreeAndNil(fMailServers);
end;
 
function TfrmMain.SendMail(aHost: String): Boolean;
begin
Result := false;
with IdSMTP do
 
begin
 
Caption := 'Trying to sendmail via: ' + aHost;
 
Msg('Trying to sendmail via: ' + aHost);
 
Host := aHost;
 
try
 
Msg('Attempting connect');
 
Connect;
 
Msg('Successful connect ... sending message');
 
Send(IdMessage);
 
Msg('Attempting disconnect');
 
Disconnect;
  msg
('Successful disconnect');
 
Result := true;
 
except on E : Exception do
   
begin
   
if connected then try disconnect; except end;
   
Msg('Error sending message');
    result
:= false;
   
ShowMessage(E.Message);
   
end;
 
end;
 
end;
Caption := '';
end;
 
 
function TfrmMain.ValidData: Boolean;
var ErrString:string;
begin
Result := True;
ErrString := '';
if trim(edtDNS.text) = '' then ErrString := ErrString +  #13 + #187 + 'DNS server not filled in';
if trim(edtSender.text) = '' then ErrString := ErrString + #13 + #187 + 'Sender email not filled in';
if trim(edtRecipient.text) = '' then ErrString := ErrString +  #13 + #187 + 'Recipient not filled in';
if ErrString <> '' then
 
begin
 
MessageDlg('Cannot proceed due to the following errors:'+#13+#10+ ErrString, mtInformation, [mbOK], 0);
 
Result := False;
 
end;
end;
 
procedure
TfrmMain.Msg(aMessage: String);
begin
sbMain
.SimpleText := aMessage;
application
.ProcessMessages;
end;
 
end.

Форма для модуля:

object frmMain: TfrmMain
 
Left = 243
 
Top = 129
 
Width = 448
 
Height = 398
 
Caption = 'INDY - SMTP Relay Demo'
 
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 Label1: TLabel
   
Left = 7
   
Top = 8
   
Width = 311
   
Height = 26
   
Caption =
     
'Demonstrates sending mail directly to a users mailbox on a remot' +
     
'e mailserver - this negates the need for a local SMTP server'
   
Font.Charset = DEFAULT_CHARSET
   
Font.Color = clGray
   
Font.Height = -11
   
Font.Name = 'MS Sans Serif'
   
Font.Style = []
   
ParentFont = False
   
WordWrap = True
 
end
 
object Label2: TLabel
   
Left = 8
   
Top = 64
   
Width = 111
   
Height = 13
   
Caption = 'DNS server IP address:'
 
end
 
object Label3: TLabel
   
Left = 8
   
Top = 123
   
Width = 104
   
Height = 13
   
Caption = 'Sender email address:'
 
end
 
object Label4: TLabel
   
Left = 288
   
Top = 64
   
Width = 49
   
Height = 13
   
Caption = 'Required !'
   
Font.Charset = DEFAULT_CHARSET
   
Font.Color = clGray
   
Font.Height = -11
   
Font.Name = 'MS Sans Serif'
   
Font.Style = []
   
ParentFont = False
 
end
 
object Label5: TLabel
   
Left = 8
   
Top = 150
   
Width = 115
   
Height = 13
   
Caption = 'Recipient email address:'
 
end
 
object Label6: TLabel
   
Left = 8
   
Top = 177
   
Width = 72
   
Height = 13
   
Caption = 'Subject of mail:'
 
end
 
object Label7: TLabel
   
Left = 8
   
Top = 204
   
Width = 66
   
Height = 13
   
Caption = 'Message text:'
 
end
 
object Label8: TLabel
   
Left = 8
   
Top = 91
   
Width = 95
   
Height = 13
   
Caption = 'DNS server timeout:'
 
end
 
object Label9: TLabel
   
Left = 336
   
Top = 124
   
Width = 49
   
Height = 13
   
Caption = 'Required !'
   
Font.Charset = DEFAULT_CHARSET
   
Font.Color = clGray
   
Font.Height = -11
   
Font.Name = 'MS Sans Serif'
   
Font.Style = []
   
ParentFont = False
 
end
 
object Label10: TLabel
   
Left = 336
   
Top = 148
   
Width = 49
   
Height = 13
   
Caption = 'Required !'
   
Font.Charset = DEFAULT_CHARSET
   
Font.Color = clGray
   
Font.Height = -11
   
Font.Name = 'MS Sans Serif'
   
Font.Style = []
   
ParentFont = False
 
end
 
object sbMain: TStatusBar
   
Left = 0
   
Top = 352
   
Width = 440
   
Height = 19
   
Panels = <>
 
end
 
object edtDNS: TEdit
   
Left = 128
   
Top = 60
   
Width = 153
   
Height = 21
   
TabOrder = 1
 
end
 
object edtSender: TEdit
   
Left = 128
   
Top = 119
   
Width = 205
   
Height = 21
   
TabOrder = 2
 
end
 
object edtRecipient: TEdit
   
Left = 128
   
Top = 146
   
Width = 205
   
Height = 21
   
TabOrder = 3
 
end
 
object edtSubject: TEdit
   
Left = 128
   
Top = 173
   
Width = 205
   
Height = 21
   
TabOrder = 4
 
end
 
object mmoMessageText: TMemo
   
Left = 128
   
Top = 200
   
Width = 205
   
Height = 113
   
TabOrder = 5
 
end
 
object btnSendMail: TButton
   
Left = 258
   
Top = 321
   
Width = 75
   
Height = 25
   
Caption = 'Send mail !'
   
TabOrder = 6
   
OnClick = btnSendMailClick
 
end
 
object btnExit: TButton
   
Left = 356
   
Top = 8
   
Width = 75
   
Height = 25
   
Caption = 'E&xit'
   
TabOrder = 7
   
OnClick = btnExitClick
 
end
 
object edtTimeOut: TEdit
   
Left = 128
   
Top = 87
   
Width = 61
   
Height = 21
   
TabOrder = 8
   
Text = '5000'
 
end
 
object IdMessage: TIdMessage
   
AttachmentEncoding = 'MIME'
   
BccList = <>
   
CCList = <>
   
Encoding = meMIME
   
Recipients = <>
   
ReplyTo = <>
   
Left = 12
   
Top = 236
 
end
 
object IdDNSResolver: TIdDNSResolver
   
Port = 53
   
ReceiveTimeout = 60
   
QueryRecords = []
   
Left = 12
   
Top = 268
 
end
 
object IdSMTP: TIdSMTP
   
MaxLineAction = maException
   
ReadTimeout = 0
   
Port = 25
   
AuthenticationType = atNone
   
Left = 12
   
Top = 204
 
end
 
object IdAntiFreeze: TIdAntiFreeze
   
Left = 12
   
Top = 300
 
end
end

Автор: Vit

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