Использование SMTP Relay Server . Delphi , Интернет и Сети , E-mail

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

Это проект Delphi, который демонстрирует, как отправить электронное письмо напрямую пользователю в его почтовый ящик на удаленном сервере с использованием библиотеки Indy. Код написан на языке Pascal и использует компонент TIdMessage для создания сообщения электронной почты, а компонент TIdSMTP для отправки его на удаленный сервер.

В этом проекте есть несколько основных компонентов:

Код хорошо структурирован с ясными комментариями и именами переменных. Однако, есть несколько областей, которые можно улучшить:

Вот обновленная версия кода, которая решает эти проблемы:

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)
    EdtDNS: TEdit;
    EdtSender: TEdit;
    EdtRecipient: TEdit;
    EdtSubject: TEdit;
    MmoMessageText: TMemo;
    BtnSendMail: TButton;
    BtnExit: TButton;
    IdMessage: TIdMessage;
    IdDNSResolver: TIdDNSResolver;
    IdSMTP: TIdSMTP;
    IdAntiFreeze: TIdAntiFreeze;
    procedure btnExitClick(Sender: TObject);
    procedure btnSendMailClick(Sender: TObject);
  private
    { Private declarations }
  public
    fMailServers: TStringList;
    function PadZero(s: string): string; overload;
    function GetMailServers: Boolean; overload;
    function ValidData: Boolean; overload;
    procedure SendMail; overload;
    function SendMail(aHost: string): Boolean; overload;
    procedure LockControls;
    procedure UnlockControls;
  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 preference sorting

function TfrmMain.PadZero(s: string): string;
begin
  if length(s) < 2 then
    s := '0' + s;
  Result := s;
end;

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.SendMail: Boolean;
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;

function TfrmMain.ValidData: Boolean;
var
  ErrString: string;
begin
  Result := True;
  ErrString := '';
  if trim(EdtDNS.Text) = '' then
    ErrString := ErrString + #13 + '»' + ' DNS server not filled in';
  if trim(EdtSender.Text) = '' then
    ErrString := ErrString + #13 + '»' + ' Sender email not filled in';
  if trim(EdtRecipient.Text) = '' then
    ErrString := ErrString + #13 + '»' + ' 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;

end.

В обновленном коде добавлены обработка ошибок и валидация вводных данных. Код также разделен на две части: GUI-компоненты и Indy-компоненты, что улучшает организацию кода.

Использование SMTP Relay Server - отправка электронной почты напрямую, минуя любые промежуточные сервера.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш

Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS