已經用 IdSMTPServer 搜尋過本站, 發現這篇 
http://delphi.ktop.com.tw/topic.php?topic_id=39078
(為了方便閱讀, 和了解運作, 多加了 Memo2 和小作修改 在 Outlook Express 增加帳號 test@127.0.0.1 SMTP Server / POP3 Server 都是 127.0.0.1 active SMTP Server 後, 信件寄出, 從 "寄件匣" 消失, "寄件備份" 出現, 但是不論寄到哪個 ISP 的信箱, 都沒有收到信件 是否 IdSMTPServer 還要設定什麼屬性值 ?

<textarea class="delphi" rows="10" cols="60" name="code">unit Unit1;    {-----------------------------------------------------------------------------
Demo Name: SMTPSever demo
Author: Andrew Neillans
Copyright: Indy Pit Crew
Purpose:
History:
Date: 27/10/2002 01:27:09
Checked with Indy version: 9.0 - Allen O'Neill - Springboard Technologies Ltd - http://www.springboardtechnologies.com
-----------------------------------------------------------------------------
Notes:     Demonstration of SMTPSerer (by use of comments only!! - read the RFC to understand how to
store and manage server data, and thus be able to use this component effectivly)    }    interface    uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdBaseComponent, IdComponent, IdTCPServer, IdSMTPServer, StdCtrls,
  IdMessage, IdEMailAddress;
  
type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    ToLabel: TLabel;
    FromLabel: TLabel;
    SubjectLabel: TLabel;
    IdSMTPServer1: TIdSMTPServer;
    Label4: TLabel;
    Button1: TButton;
    Button2: TButton;
    Memo2: TMemo;        procedure IdSMTPServer1ADDRESSError(AThread: TIdPeerThread; const CmdStr: String);
    procedure IdSMTPServer1CommandAUTH(AThread: TIdPeerThread;  const CmdStr: String);
    procedure IdSMTPServer1CommandCheckUser(AThread: TIdPeerThread; const Username, Password: String; var Accepted: Boolean);
    procedure IdSMTPServer1CommandQUIT(AThread: TIdPeerThread);
    procedure IdSMTPServer1CommandX(AThread: TIdPeerThread; const CmdStr: String);
    procedure IdSMTPServer1CommandMAIL(const ASender: TIdCommand; var Accept: Boolean; EMailAddress: String);
    procedure IdSMTPServer1CommandRCPT(const ASender: TIdCommand; var Accept, ToForward: Boolean; EMailAddress: String; var CustomError: String);
    procedure IdSMTPServer1ReceiveRaw(ASender: TIdCommand; var VStream: TStream; RCPT: TIdEMailAddressList; var CustomError: String);
    procedure IdSMTPServer1ReceiveMessage(ASender: TIdCommand; var AMsg: TIdMessage; RCPT: TIdEMailAddressList; var CustomError: String);
    procedure IdSMTPServer1ReceiveMessageParsed(ASender: TIdCommand; var AMsg: TIdMessage; RCPT: TIdEMailAddressList; var CustomError: String);        procedure IdSMTPServer1CommandHELP(ASender: TIdCommand);
    procedure IdSMTPServer1CommandSAML(ASender: TIdCommand);
    procedure IdSMTPServer1CommandSEND(ASender: TIdCommand);
    procedure IdSMTPServer1CommandSOML(ASender: TIdCommand);
    procedure IdSMTPServer1CommandTURN(ASender: TIdCommand);
    procedure IdSMTPServer1CommandVRFY(ASender: TIdCommand);        procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);        procedure FormCreate(Sender: TObject);      private
    { Private declarations }
  public
    { Public declarations }
  end;    var
  Form1: TForm1;    implementation    {$R *.dfm}    procedure TForm1.IdSMTPServer1ADDRESSError(AThread: TIdPeerThread; const CmdStr: String);
begin
  // Send the Address Error String - this *WILL* be coded in eventually.
  AThread.Connection.Writeln('500 Syntax Error in MAIL FROM or RCPT TO');
  Memo2.Lines.Add('IdSMTPServer1ADDRESSError');
end;    procedure TForm1.IdSMTPServer1CommandAUTH(AThread: TIdPeerThread; const CmdStr: String);
begin
  // This is where you would process the AUTH command - for now, we send a error
  AThread.Connection.Writeln(IdSMTPServer1.Messages.ErrorReply);
  Memo2.Lines.Add('IdSMTPServer1CommandAUTH');
end;    procedure TForm1.IdSMTPServer1CommandCheckUser(AThread: TIdPeerThread; const Username, Password: String; var Accepted: Boolean);
begin
  // This event allows you to 'login' a user - this is used internall in the
  // IdSMTPServer to validate users connecting using the AUTH.
  Accepted := False;
  Memo2.Lines.Add('IdSMTPServer1CommandCheckUser');
end;    procedure TForm1.IdSMTPServer1CommandQUIT(AThread: TIdPeerThread);
begin
  // Process any logoff events here - e.g. clean temp files
  Memo2.Lines.Add('IdSMTPServer1CommandQUIT');
end;    procedure TForm1.IdSMTPServer1CommandX(AThread: TIdPeerThread; const CmdStr: String);
begin
  // You can use this for debugging :)
  Memo2.Lines.Add('IdSMTPServer1CommandX');
end;    procedure TForm1.IdSMTPServer1CommandMAIL(const ASender: TIdCommand; var Accept: Boolean; EMailAddress: String);
begin
  // This is required!
  // You check the EMAILADDRESS here to see if it is to be accepted / processed.
  // Set Accept := True if its allowed
  Accept := True;
  Memo2.Lines.Add('IdSMTPServer1CommandMAIL');
end;    procedure TForm1.IdSMTPServer1CommandRCPT(const ASender: TIdCommand; var Accept, ToForward: Boolean; EMailAddress: String;
var
  CustomError: String);
begin
  // This is required!
  // You check the EMAILADDRESS here to see if it is to be accepted / processed.
  // Set Accept := True if its allowed
  // Set ToForward := True if its needing to be forwarded.
  Accept := True;
  Memo2.Lines.Add('IdSMTPServer1CommandRCPT');
end;    procedure TForm1.IdSMTPServer1ReceiveRaw(ASender: TIdCommand; var VStream: TStream; RCPT: TIdEMailAddressList;
var
  CustomError: String);
begin
  // This is the main event for receiving the message itself if you are using
  // the ReceiveRAW method
  // The message data will be given to you in VSTREAM
  // Capture it using a memorystream, filestream, or whatever type of stream
  // is suitable to your storage mechanism.
  // The RCPT variable is a list of recipients for the message
  Memo2.Lines.Add('IdSMTPServer1ReceiveRaw');
end;    procedure TForm1.IdSMTPServer1ReceiveMessage(ASender: TIdCommand; var AMsg: TIdMessage; RCPT: TIdEMailAddressList;
var
  CustomError: String);
begin
  // This is the main event if you have opted to have idSMTPServer present the message packaged as a TidMessage
  // The AMessage contains the completed TIdMessage.
  // NOTE: Dont forget to add IdMessage to your USES clause!      ToLabel.Caption := AMsg.Recipients.EMailAddresses;
  FromLabel.Caption := AMsg.From.Text;
  SubjectLabel.Caption := AMsg.Subject;
  Memo1.Lines := AMsg.Body;      // Implement your file system here :)
  Memo2.Lines.Add('IdSMTPServer1ReceiveMessage');
end;    procedure TForm1.IdSMTPServer1ReceiveMessageParsed(ASender: TIdCommand; var AMsg: TIdMessage; RCPT: TIdEMailAddressList;
var
  CustomError: String);
begin
  // This is the main event if you have opted to have the idSMTPServer to do your parsing for you.
  // The AMessage contains the completed TIdMessage.
  // NOTE: Dont forget to add IdMessage to your USES clause!      ToLabel.Caption := AMsg.Recipients.EMailAddresses;
  FromLabel.Caption := AMsg.From.Text;
  SubjectLabel.Caption := AMsg.Subject;
  Memo1.Lines := AMsg.Body;      // Implement your file system here :)
  Memo2.Lines.Add('IdSMTPServer1ReceiveMessageParsed');
end;    procedure TForm1.IdSMTPServer1CommandHELP(ASender: TIdCommand);
begin
  // here you can send back a lsit of supported server commands
  Memo2.Lines.Add('IdSMTPServer1CommandHELP');
end;    procedure TForm1.IdSMTPServer1CommandSAML(ASender: TIdCommand);
begin
  // not really used anymore - see RFC for information
  Memo2.Lines.Add('IdSMTPServer1CommandSMAL');
end;    procedure TForm1.IdSMTPServer1CommandSEND(ASender: TIdCommand);
begin
  // not really used anymore - see RFC for information
  Memo2.Lines.Add('IdSMTPServer1CommandSEND');
end;    procedure TForm1.IdSMTPServer1CommandSOML(ASender: TIdCommand);
begin
  // not really used anymore - see RFC for information
  Memo2.Lines.Add('IdSMTPServer1CommandSOML');
end;    procedure TForm1.IdSMTPServer1CommandTURN(ASender: TIdCommand);
begin
  // not really used anymore - see RFC for information
  Memo2.Lines.Add('IdSMTPServer1CommandTURN');
end;    procedure TForm1.IdSMTPServer1CommandVRFY(ASender: TIdCommand);
begin
  // not really used anymore - see RFC for information
  Memo2.Lines.Add('IdSMTPServer1CommandVRFY');
end;    procedure TForm1.Button1Click(Sender: TObject);
begin
  IdSMTPServer1.active := true;
  Button1.Enabled:=False;
  Button2.Enabled:=true;
end;    procedure TForm1.Button2Click(Sender: TObject);
begin
  IdSMTPServer1.active := false;
  Button1.Enabled:=True;
  Button2.Enabled:=False;
end;    procedure TForm1.FormCreate(Sender: TObject);
begin
  Button1.Enabled:=True;
  Button2.Enabled:=False;
end;    end.    </textarea> 

------
能力不足，求助於人；有能力時，幫幫別人；如果您滿意答覆，請適時結案！

子曰：問有三種，不懂則問，雖懂有疑則問，雖懂而想知更多則問！

你的"簡易型"MailServer 只做了收信和收信後顯示在Form上面的程式 當然不會寄送到你想要寄的信箱阿!! 除了你上面的程式碼外，針對轉信部分(Relay) 你還得實作 信件佇列管理，處理佇列的Pickup程式，外寄的功能也得作 另外，多執行緒接收的處理，帳號的管理等等 很多都要另外做的，不是複製簡單範例就可以達到ㄧ部MailServer的基本功能。

用 Google 找 IdSMTPServer1ReceiveRaw, 只有兩篇一篇就是上面的範例一篇網站上已無資料, 頁庫存檔中找到如下(但是有問題) 

http://66.102.7.104/search?q=cache:RGJ7um6g6n4J:www.nlcsharp.com/Forum/showthread.php?t=3688 IdSMTPServer1ReceiveRaw&hl=zh-TW

<textarea class="delphi" rows="10" cols="60" name="code">
procedure TForm1.IdSMTPServer1ReceiveRaw(ASender: TIdCommand;
  var VStream: TStream; RCPT: TIdEMailAddressList;
  var CustomError: String);
var 
  MemStream:TMemoryStream;
  i:integer;      MailMsg : TidMessage;                // 這是我補上的
  E_AddressRcpt : String;        // 這是我補上的        
  Smtp_Client1 : TIdSMTP;        // 這是我補上的    begin
  MemStream := TMemorystream.Create;
  MailMsg := TidMessage.Create(nil);
  VStream.Seek(0, soFromEnd);
  VStream.Write('.'#10#13, 3);
  MemStream.LoadFromStream(VStream);
  MemStream.SaveToFile('c:\Pizza');
  MailMsg.LoadFromFile('c:\Pizza');      for i := 0 to Rcpt.Count -1 do begin
    E_AddressRcpt := Rcpt.Items[i].Address;
  end; 
  MailMsg.Recipients.EMailAddresses := E_AddressRcpt; 
  Smtp_Client.PSendMail;        // 有問題      MemStream.Free;
  MailMsg.Free;
  DeleteFile('c:\Pizza');
end;
</textarea> 

這行有問題 Smtp_Client.PSendMail IdSMTP 沒有稱為 PSendMail 的 Method 繼續想辦法找範例, 有人可以提供嗎 ? THX (只要寄信, 轉信, 不需要有信箱管理 和 收信)

------
能力不足，求助於人；有能力時，幫幫別人；如果您滿意答覆，請適時結案！

子曰：問有三種，不懂則問，雖懂有疑則問，雖懂而想知更多則問！

Indy 網站上的範例 SMTPServer 
http://www.projectindy.org/Demos/index.iwp

<textarea class="delphi" rows="10" cols="60" name="code">
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  23278: Main.pas 
{
{   Rev 1.0.1.0    25/10/2004 22:49:48  ANeillans    Version: 9.0.17
{ Verified
}
{
{   Rev 1.0    12/09/2003 21:41:36  ANeillans
{ Initial Checking.
{ Verified with Indy 9 and D7
}
{
  Demo Name:  SMTP Server
  Created By: Andy Neillans
          On: 27/10/2002      Notes:
   Demonstration of SMTPServer (by use of comments only!!)
   Read the RFC to understand how to store and manage server data, and
   therefore be able to use this component effectivly.      Version History:
    12th Sept 03: Andy Neillans
                  Cleanup. Added some basic syntax checking for example.
     
  Tested:
   Indy 9:
     D5:     Untested
     D6:     Untested
     D7:     25th Oct 2004 by Andy Neillans
             Tested with Telnet and Outlook Express 6
}
unit Main;    interface    uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdBaseComponent, IdComponent, IdTCPServer, IdSMTPServer, StdCtrls,
  IdMessage, IdEMailAddress;    type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    ToLabel: TLabel;
    FromLabel: TLabel;
    SubjectLabel: TLabel;
    IdSMTPServer1: TIdSMTPServer;
    Label4: TLabel;
    btnServerOn: TButton;
    btnServerOff: TButton;
    procedure IdSMTPServer1CommandAUTH(AThread: TIdPeerThread;
      const CmdStr: String);
    procedure IdSMTPServer1CommandCheckUser(AThread: TIdPeerThread;
      const Username, Password: String; var Accepted: Boolean);
    procedure IdSMTPServer1CommandQUIT(AThread: TIdPeerThread);
    procedure IdSMTPServer1CommandX(AThread: TIdPeerThread;
      const CmdStr: String);
    procedure IdSMTPServer1CommandMAIL(const ASender: TIdCommand;
      var Accept: Boolean; EMailAddress: String);
    procedure IdSMTPServer1CommandRCPT(const ASender: TIdCommand;
      var Accept, ToForward: Boolean; EMailAddress: String;
      var CustomError: String);
    procedure IdSMTPServer1ReceiveRaw(ASender: TIdCommand;
      var VStream: TStream; RCPT: TIdEMailAddressList;
      var CustomError: String);
    procedure IdSMTPServer1ReceiveMessage(ASender: TIdCommand;
      var AMsg: TIdMessage; RCPT: TIdEMailAddressList;
      var CustomError: String);
    procedure IdSMTPServer1ReceiveMessageParsed(ASender: TIdCommand;
      var AMsg: TIdMessage; RCPT: TIdEMailAddressList;
      var CustomError: String);
    procedure IdSMTPServer1CommandHELP(ASender: TIdCommand);
    procedure IdSMTPServer1CommandSAML(ASender: TIdCommand);
    procedure IdSMTPServer1CommandSEND(ASender: TIdCommand);
    procedure IdSMTPServer1CommandSOML(ASender: TIdCommand);
    procedure IdSMTPServer1CommandTURN(ASender: TIdCommand);
    procedure IdSMTPServer1CommandVRFY(ASender: TIdCommand);
    procedure btnServerOnClick(Sender: TObject);
    procedure btnServerOffClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;    var
  Form1: TForm1;    implementation    {$R *.DFM}    procedure TForm1.IdSMTPServer1CommandAUTH(AThread: TIdPeerThread;
  const CmdStr: String);
begin
 // This is where you would process the AUTH command - for now, we send a error
 AThread.Connection.Writeln(IdSMTPServer1.Messages.ErrorReply);
end;    procedure TForm1.IdSMTPServer1CommandCheckUser(AThread: TIdPeerThread;
  const Username, Password: String; var Accepted: Boolean);
begin
 // This event allows you to 'login' a user - this is used internall in the
 // IdSMTPServer to validate users connecting using the AUTH.
 Accepted := False;
end;    procedure TForm1.IdSMTPServer1CommandQUIT(AThread: TIdPeerThread);
begin
// Process any logoff events here - e.g. clean temp files
end;    procedure TForm1.IdSMTPServer1CommandX(AThread: TIdPeerThread;
  const CmdStr: String);
begin
 // You can use this for debugging :)
 // It should be noted, that no standard clients ever send this command.
end;    procedure TForm1.IdSMTPServer1CommandMAIL(const ASender: TIdCommand;
  var Accept: Boolean; EMailAddress: String);
Var
 IsOK : Boolean;
begin
 // This is required!
 // You check the EMAILADDRESS here to see if it is to be accepted / processed.
 IsOK := False;
 if Pos('@', EMailAddress) > 0 then   // Basic checking for syntax
  IsOK := True;     // Set Accept := True if its allowed
 if IsOK then
  Accept := True
 Else
  Accept := False;
end;    procedure TForm1.IdSMTPServer1CommandRCPT(const ASender: TIdCommand;
  var Accept, ToForward: Boolean; EMailAddress: String;
  var CustomError: String);
Var
 IsOK : Boolean;
begin
 // This is required!
 // You check the EMAILADDRESS here to see if it is to be accepted / processed.
 // Set Accept := True if its allowed
 // Set ToForward := True if its needing to be forwarded.
 IsOK := False;
 if Pos('@', EMailAddress) > 0 then   // Basic checking for syntax
  IsOK := True
 Else
  CustomError := '500 No at sign'; // If you are going to use the CustomError property, you need to include the error code
                                   // This allows you to use the extended error reporting.     // Set Accept := True if its allowed
 if IsOK then
  Accept := True
 Else
  Accept := False;
end;    procedure TForm1.IdSMTPServer1ReceiveRaw(ASender: TIdCommand;
  var VStream: TStream; RCPT: TIdEMailAddressList;
  var CustomError: String);
begin
// This is the main event for receiving the message itself if you are using
// the ReceiveRAW method
// The message data will be given to you in VSTREAM
// Capture it using a memorystream, filestream, or whatever type of stream
// is suitable to your storage mechanism.
// The RCPT variable is a list of recipients for the message
end;    procedure TForm1.IdSMTPServer1ReceiveMessage(ASender: TIdCommand;
  var AMsg: TIdMessage; RCPT: TIdEMailAddressList;
  var CustomError: String);
begin
// This is the main event if you have opted to have idSMTPServer present the message packaged as a TidMessage
// The AMessage contains the completed TIdMessage.
// NOTE: Dont forget to add IdMessage to your USES clause!    ToLabel.Caption := AMsg.Recipients.EMailAddresses;
FromLabel.Caption := AMsg.From.Text;
SubjectLabel.Caption := AMsg.Subject;
Memo1.Lines := AMsg.Body;    // Implement your file system here :)
end;    procedure TForm1.IdSMTPServer1ReceiveMessageParsed(ASender: TIdCommand;
  var AMsg: TIdMessage; RCPT: TIdEMailAddressList;
  var CustomError: String);
begin
// This is the main event if you have opted to have the idSMTPServer to do your parsing for you.
// The AMessage contains the completed TIdMessage.
// NOTE: Dont forget to add IdMessage to your USES clause!    ToLabel.Caption := AMsg.Recipients.EMailAddresses;
FromLabel.Caption := AMsg.From.Text;
SubjectLabel.Caption := AMsg.Subject;
Memo1.Lines := AMsg.Body;    // Implement your file system here :)    end;    procedure TForm1.IdSMTPServer1CommandHELP(ASender: TIdCommand);
begin
// here you can send back a lsit of supported server commands
end;    procedure TForm1.IdSMTPServer1CommandSAML(ASender: TIdCommand);
begin
// not really used anymore - see RFC for information
end;    procedure TForm1.IdSMTPServer1CommandSEND(ASender: TIdCommand);
begin
// not really used anymore - see RFC for information
end;    procedure TForm1.IdSMTPServer1CommandSOML(ASender: TIdCommand);
begin
// not really used anymore - see RFC for information
end;    procedure TForm1.IdSMTPServer1CommandTURN(ASender: TIdCommand);
begin
// not really used anymore - see RFC for information
end;    procedure TForm1.IdSMTPServer1CommandVRFY(ASender: TIdCommand);
begin
// not really used anymore - see RFC for information
end;    procedure TForm1.btnServerOnClick(Sender: TObject);
begin
 btnServerOn.Enabled := False;
 btnServerOff.Enabled := True;
 IdSMTPServer1.active := true;
end;    procedure TForm1.btnServerOffClick(Sender: TObject);
begin
 btnServerOn.Enabled := True;
 btnServerOff.Enabled := False;
 IdSMTPServer1.active := false;
end;    end.    </textarea> 

發表人 - pcboy2 於 2005/07/01 09:18:16

------
能力不足，求助於人；有能力時，幫幫別人；如果您滿意答覆，請適時結案！

子曰：問有三種，不懂則問，雖懂有疑則問，雖懂而想知更多則問！

Indy 網站上的範例 SMTPRelay 
http://www.projectindy.org/Demos/index.iwp

<textarea class="delphi" rows="10" cols="60" name="code">
{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence                                   }
{ Team Coherence is Copyright 2002 by Quality Software Components      }
{                                                                      }
{ For further information / comments, visit our WEB site at            }
{ http://www.TeamCoherence.com                                         }
{**********************************************************************}
{}
{ $Log:  23283: fMain.pas 
{
{   Rev 1.1    25/10/2004 22:49:38  ANeillans    Version: 9.0.17
{ Verified
}
{
{   Rev 1.0    12/09/2003 21:50:22  ANeillans
{ Intial Checkin
{ Verified with D7 and Indy 9
{ Added an event log and a few more comments
}
{
  Demo Name:  SMTP Relay
  Created By: Allen O'Neill
          On: 27/10/2002      Notes:
   Demonstrates sending an email without the use of a local SMTP server
   This works by extracting the domain part form the recipient email address,
   then doing an MX lookup against a DNS server for that domain part,
   and finally connecting directly to the SMTP server that the MX record
   point to, to deliver the message.      Version History:
    12th Sept 03: Andy Neillans
                  Added an event log and a few more comments
     
  Tested:
   Indy 9:
     D5:     Untested
     D6:     Untested
     D7:     25th Oct 2004 by Andy Neillans
             Tested with Telnet and Outlook Express 6
}    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;
    lbEvents: TListBox;
    procedure btnExitClick(Sender: TObject);
    procedure btnSendMailClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  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
// This function does the business part of resolving the domain name and fetching
// the mail server list    if not assigned(fmailServers) then fMailServers := TStringList.Create;
fmailServers.clear;    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 for domain: '   LDomainPart);
  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;
    // Ignore duplicate servers
    fMailServers.Duplicates := dupIgnore;
    Result := true;
    end
  else
   begin
    Msg('No response from the 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 '   LDomainPart);
    MessageDlg('Error resolving domain: '   e.message, mtInformation, [mbOK], 0);
    Result := false;
    end;
  end;      end;
end;    // Used in DNS preferance sorting
procedure TfrmMain.LockControls;
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
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
 // Here we do some quick validation of the boxes on the form - just to make sure :)
 
 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
   lbEvents.Items.Add('Validation Error: '   ErrString);
   MessageDlg('Cannot proceed due to the following errors:' #13 #10  ErrString, mtInformation, [mbOK], 0);
   Result := False;
  end;
end;    procedure TfrmMain.Msg(aMessage: String);
begin
 lbEvents.Items.Add(AMessage);
 sbMain.SimpleText := aMessage;
 application.ProcessMessages;
end;    end.    </textarea>     

------
能力不足，求助於人；有能力時，幫幫別人；如果您滿意答覆，請適時結案！

子曰：問有三種，不懂則問，雖懂有疑則問，雖懂而想知更多則問！