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

Previous  Top  Next

    
 

 

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

 

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

Code:

unit fMain;

 

{©Drkb v.3(2007): www.drkb.ru,

®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}

 

 

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.

 

 

 

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

Code:

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

 

©Drkb::03404

Автор: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)

 

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