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

Использование 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
Author: Vit
Source: Vingrad.ru http://forum.vingrad.ru
ID: 03404
Category:Связь
Category:Электронная почта