Email服务器

开发平台：
Delphi

uSendMail.~pas：源码内容
							unit uSendMail;
interface
uses Classes,SysUtils,Dialogs, windows,IdMessage, IdEmailAddress,IdSMTP,
     IdAttachmentFile, IdText, IdSASL_CRAM_MD5,IdUserPassProvider,Contnrs,objs,
     Messages,syncobjs;
type
  TOnError=procedure (Sender:TObject;ErrMsg:string) of object;
  TDestinationPart = class(TPersistent)
  public
    SendTo : ShortString;
    CCSendTo : ShortString; //抄送
    BccSendTo : ShortString;//暗送
    ReturnAddy: ShortString; //收地址
    Subject : ShortString;
    Body : string;
    Files : TStringList;
    procedure AssignTo(Dest: TPersistent);override;
    constructor Create(aSndTo, aCCSndTo, aBCCSndTo, aRtrnRcptAddy, aSubject, aBody:string; aFiles:TStringList=nil);overload;
    constructor Create; overload;
    destructor destroy; override;
  end;
  TOriginPart = class(TPersistent)
  public
    AuthType : TIdSMTPAuthenticationType;
    FromAddy : string;
    UserName : string;
    Password : string;
    Server : string;
    Port : integer;
    Debug : boolean;
    procedure AssignTo(OriginPart: TPersistent);override;
    constructor Create(aAuthType:TIdSMTPAuthenticationType; aFromAddy, aUserName, aPassword, aServer: string; aPort:integer);overload;
    constructor Create(aUserName, aPassword:string);overload;
    constructor CreateFromFile(fn:string); procedure SaveToFile(fn:string);
  end;
  TMailMessage = class
  public
  private
    Destination : TDestinationPart;
    Origin : TOriginPart;
    SentOk : boolean;
    SentMsg : string;
  public
    constructor Create(Dest:TDestinationPart; Orig:TOriginPart);
    procedure SendNow;
    destructor destroy;override;
  published
    property Success:boolean read SentOk ;
    property ErrorMSG:String  read SentMsg;
  end;
  TBaseThreadMailMessage = class(TThread)
  protected
    FOnSendComplete:TNotifyEvent;
    FOnSendError:TOnError;
    FErrMsg:string;
    
    procedure DoOnComplete; virtual;
    procedure DoOnError; virtual;
  public
    property OnSendComplete:TNotifyEvent read FOnSendComplete write FOnSendComplete;
    property OnSendError:TOnError read FOnSendError write FOnSendError;
  end;
   TThreadMailMessage = class(TBaseThreadMailMessage)
   protected
     MailMsg : TMailMessage;
     procedure Execute; override;
   public
     constructor Create(aDestinationPart:TDestinationPart;aOriginPart:TOriginPart);
   end;
  TMultiThreadMailMessage=class(TBaseThreadMailMessage)
   protected
     FDest:array of  TDestinationPart ;
     FOrig:array of TOriginPart;
     procedure Execute; override;
   public
     constructor Create(const aDestinationPart: array of TDestinationPart;const aOriginPart:array of TOriginPart);
     destructor Destroy;override; 
   end;
   TEmailInfo=Class(TPersistent)
   private
     FSend:TOriginPart;
     FRecv:TDestinationPart;
     FUniqueID:String;
     FIsError:Boolean;
    procedure SetFRecv(const Value: TDestinationPart);
    procedure SetSend(const Value: TOriginPart);
   public
     Constructor Create;
     destructor Destroy; override;
     procedure AssignTo(Dest: TPersistent);override;
     property Send:TOriginPart read FSend write SetSend;
     property Recv:TDestinationPart read FRecv write SetFRecv;
     property Id:string read FUniqueID write FUniqueID;
     property IsError:Boolean read FIsError write FIsError;
   end;
   TEmailInfoList=class(TList)
   protected
     procedure Notify(Ptr: Pointer; Action: TListNotification); Override;
   end;
   TEmailQueue=class(TCustomQueue)
   private
    function GetCount: integer;
   public
     Constructor Create;
     Destructor Destroy; override;
     Procedure Push(Email:TEmailInfo);
     Function Pop:TEmailInfo;
     Function Peek:TEmailInfo;
    property Count:integer Read GetCount ;
   end;
   
   { 使用方法
    1，TEmailSenderMgr.Create;
    2，设置  OnError，OnComplete事件
    3，push一封email
    4，Send
    5，发送完毕释放
   }
Const
   WM_Begin=WM_USER+555;
   WM_OneSendBegin =WM_USER+556;
   WM_OneSendEnd=WM_USER+557;
   WM_Complete=WM_USER+558;
type
  TOnOneSendEnd=procedure(Sender:TObject;Email:TEmailInfo)of object;
  TSendError=procedure (Sender:TObject;Email:TEmailInfo;Msg:String) of Object;
   TEmailSenderMgr=class
   private
     FQueue:TEmailQueue;
     FCS:TCriticalSection;
     FThreadMailMessage:TThreadMailMessage;
     FOnComplete:TNotifyEvent;
     FOnOneSend:TOnOneSendEnd;
     FOneSendEnd:TOnOneSendEnd;
     FIsSending:Boolean;
     FOnError: TSendError;
   protected
     FWindowHandle:THandle;
    procedure MyOnComplete(Sender:TObject);
    procedure WndProc(var Msg: TMessage);
    procedure DoOnError(Sender:TObject;Msg:String);
   public
     Constructor Create;
     Destructor Destroy; override;
     Procedure Push(Email:TEmailInfo);
     Function Pop:TEmailInfo;
     Function Peek:TEmailInfo;
     function HasEmail:Boolean;
     procedure Send;
     property OnComplete:TNotifyEvent read FOnComplete write FOnComplete;
     property OnOneSend:TOnOneSendEnd read FOnOneSend write FOnOneSend;
     property OnOneSendEnd:TOnOneSendEnd read FOneSendEnd write FOneSendEnd;
     property OnSendError:TSendError read FOnError write FOnError;
   end;
 function ActiveMailThreadCount:integer;
implementation
uses uCommon;
var
  ActiveMailThreads:Integer;
  
{TMailMessage}
constructor TMailMessage.Create(Dest:TDestinationPart; Orig:TOriginPart);
begin
  Destination:=TDestinationPart.Create('','','','','','',TStringList.Create);
  if Dest<>nil then
    Destination.Assign(Dest);
  Origin:=TOriginPart.Create(atNone,'','','','',0);
  if Orig<>nil then
    Origin.Assign(Orig);
end;
procedure TMailMessage.SendNow;
var
  MsgSend:TIdMessage;
  SMTP:TIdSMTP;
  ix:integer;
  SASLLogin:TIdSASLCramMd5;
  UserPassProv:TIdUserPassProvider;
  textPart:TIdText;
  //AEmail: TIdEmailAddressItem;
begin
  SentOk:=False;
  SentMsg:='';
  
  MsgSend:=TIdMessage.Create(nil);
  with MsgSend do
  begin
      if (Destination.Files<>nil) AND (Destination.Files.Count>0) then
        contentType:='multipart/alternative';
      From.Text := Origin.FromAddy;
      From.Name:=Origin.UserName;
      Recipients.EMailAddresses := Destination.SendTo;
      Subject := Destination.Subject;
      Priority := mpNormal;
      CCList.EMailAddresses := Destination.CCSendTo;
      BccList.EMailAddresses := Destination.BCCSendTo;
      ReceiptRecipient.Text := Destination.ReturnAddy;
      textPart:=TIdText.Create(MsgSend.MessageParts,nil);
      textPart.ContentType:='text/plain';
      textPart.Body.Add(Destination.Body);
      {textPart:=TIdText.Create(MsgSend.MessageParts,nil);
      textPart.ContentType:='text/plain';
      textPart.Body.Add(Destination.Body); }
      for ix:=0 to Destination.Files.Count-1 do
        TIdAttachmentFile.Create(MsgSend.MessageParts, Destination.Files.Strings[ix]);
      
    try
      SMTP:=TIdSMTP.Create;
      {try
        TIdSSLContext.Create.Free;
        smtp.IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(smtp);
        smtp.UseTLS := utUseExplicitTLS;
      except
        smtp.IOHandler := TIdIOHandler.MakeDefaultIOHandler(smtp);
        smtp.UseTLS := utNoTLSSupport;
      end;  }
      smtp.ManagedIOHandler := True;
      try
        SMTP.AuthType := Origin.AuthType;
        SMTP.UserName := Origin.UserName; //setup the user name
        SMTP.Password := Origin.Password; //setup the password
        if SMTP.AuthType=atSASL then
        begin
          userPassProv:=TIdUserPassProvider.Create;
          userPassProv.UserName:=SMTP.UserName;
          userPassProv.Password:=SMTP.Password;
          SASLLogin:=TIdSASLCramMd5.Create;
          SASLLogin.UserPassProvider:=userPassProv; // assign the user pass provider to it
          SMTP.SASLMechanisms.Add.SASL:=SASLLogin; // add the SASL login back to the SMTP object
        end;
        SMTP.Host := Origin.Server;
        SMTP.Port := Origin.Port;
        SMTP.Connect;
        if not SMTP.Authenticate then
          raise Exception.Create('发送邮件时发生了错误. 错误原因 : 无法通过认证.');
        try
          try
            SMTP.Send(MsgSend); //send the message
            SentOk:=true;
          finally
            SMTP.Disconnect; //disconnect from the server
          end;
        except
          on E :Exception do
          begin
            SentOk:=false;
            SentMsg:=E.Message;
            raise Exception.Create('发送邮件时发生了错误. 错误原因 : '+E.Message);
          end;
        end;
      finally
        SMTP.Free; //free the memory end;
      end;
    finally
        MsgSend.Free; //free the message
    end;
  end;
end;
destructor TMailMessage.destroy;
begin
  Destination.Free; 
  Origin.Free;
end;
{TDestinationPart}
procedure TDestinationPart.AssignTo(Dest: TPersistent);
begin
  if Dest is TDestinationPart then
  begin
    TDestinationPart(Dest).SendTo:=SendTo;
    TDestinationPart(Dest).CCSendTo:=CCSendTo; //抄送
    TDestinationPart(Dest).BccSendTo:=BccSendTo;//暗送
    TDestinationPart(Dest).ReturnAddy:=ReturnAddy;
    TDestinationPart(Dest).Subject:=Subject;
    TDestinationPart(Dest).Body:=Body;
    TDestinationPart(Dest).Files.Assign(Files);
  end
  else raise Exception.Create('类型不同不能克隆');
end;
constructor TDestinationPart.Create(aSndTo, aCCSndTo, aBCCSndTo, aRtrnRcptAddy, aSubject, aBody:string; aFiles:TStringList);
begin
  SendTo := aSndTo; //send message to, comma separate list for multiple adddesses
  CCSendTo := aCCSndTo; //CC message to
  BccSendTo := aBCCSndTo; //BCC message to
  ReturnAddy:= aRtrnRcptAddy;
  Subject := aSubject; //what's it about
  Body := aBody; //the text, supports HTML or TEXT
  Files:=TStringList.Create; //we must have a list, create if not provided
  if aFiles<>nil then Files.assign(aFiles);
end;
constructor TDestinationPart.Create;
begin
  inherited;
   Files:=TStringList.Create;
end;
destructor TDestinationPart.destroy;
begin
  Files.Free;
end;
{TOriginPart}
procedure TOriginPart.AssignTo(OriginPart: TPersistent);
begin
  if OriginPart is  TOriginPart then
  begin
    TOriginPart(OriginPart).AuthType:=AuthType;
    TOriginPart(OriginPart).FromAddy:=FromAddy ;
    TOriginPart(OriginPart).UserName:=UserName;
    TOriginPart(OriginPart).Password:=Password;
    TOriginPart(OriginPart).Server:=Server ;
    TOriginPart(OriginPart).Port:=Port;
    TOriginPart(OriginPart).Debug:=Debug ;
  end
  else raise Exception.Create('类型不同不能克隆');
end;
constructor TOriginPart.Create(aAuthType:TIdSMTPAuthenticationType; aFromAddy, aUserName, aPassword, aServer: string; aPort:integer);
begin
  AuthType := aAuthType; //options are : 0=satNONE, 1=satDEFAULT, 2=sat
  FromAddy := aFromAddy; //me@mydomain.com
  UserName := aUserName; //me
  Password := aPassword; //mypassword
  Server := aServer; //smtp.mydomain.com
  Port := aPort; //SMTP connection port (25 is default)
  Debug := false; //debugging off/onend;
end;
constructor TOriginPart.Create(aUserName, aPassword: string);
begin
  Create(atDefault,aUserName,aUserName,aPassword,TEMailAddress.SMTPEmailSever(aUserName),25);
end;
constructor TOriginPart.CreateFromFile(fn:string);
begin
end;
procedure TOriginPart.SaveToFile(fn:string);
begin
end;
procedure IncMailThreadCount;
begin
  InterlockedIncrement(ActiveMailThreads);
end;
procedure DecMailThreadCount;
begin
  InterlockedDecrement(ActiveMailThreads);
end;
function ActiveMailThreadCount:integer;
begin
  result:=ActiveMailThreads;
end;
function MailThreadsDone:boolean;
begin
  result:=ActiveMailThreadCount=0;
end;
{TBaseThreadMailMessage}
procedure TBaseThreadMailMessage.DoOnComplete;
begin
  if Assigned(FOnSendComplete) then FOnSendComplete(Self);
end;
procedure TBaseThreadMailMessage.DoOnError;
begin
  if Assigned(FOnSendError) then FOnSendError(Self,FErrMsg);
end;
{ TThreadMailMessage }
constructor TThreadMailMessage.Create(aDestinationPart: TDestinationPart;
  aOriginPart: TOriginPart);
begin
  inherited Create(True);
  IncMailThreadCount;
  if aDestinationPart=nil then raise Exception.Create('You must supply a destination');
  if aOriginPart=nil then raise Exception.Create('You must supply an origin');
  FreeOnTerminate:=true;
  MailMsg:=TMailMessage.Create(aDestinationPart, aOriginPart);
end;
procedure TThreadMailMessage.Execute;
begin
  try
    try
      MailMsg.SendNow;
      Synchronize(DoOnComplete);
    finally
      DecMailThreadCount;
    end;
  except
    on E:Exception do
    begin
      FErrMsg:=trim(e.Message);
      Synchronize(DoOnError);
    end;
  end;
end;
{ TMultiThreadMailMessage }
constructor TMultiThreadMailMessage.Create(
  const aDestinationPart: array of TDestinationPart;
  const aOriginPart: array of TOriginPart);
var
  I:integer;
begin
  inherited Create(True);
  SetLength(FDest,Length(aDestinationPart));
  //CopyMemory(@FDest[0],@aDestinationPart[0],sizeof(TDestinationPart)*Length(aDestinationPart));
  for I:=0 to Length(aDestinationPart)-1 do
  begin
   FDest[I]:=TDestinationPart.Create;
   FDest[I].Assign(aDestinationPart[I]);
  end;
  SetLength(FOrig,Length(aOriginPart));
  //CopyMemory(@FOrig[0],@aOriginPart[0],sizeof(TOriginPart)*Length(aOriginPart));
  for I:=0 to Length(aOriginPart)-1 do
  begin
   FOrig[I]:=TOriginPart.Create;
   FOrig[I].Assign(aOriginPart[I]);
  end;
end;
destructor TMultiThreadMailMessage.Destroy;
var
  I:integer;
begin
  for I:=0 to Length(FOrig)-1 do
  begin
    FDest[I].Free;
    FOrig[I].Free;
  end;
  inherited;
end;
procedure TMultiThreadMailMessage.Execute;
var
  MailMsg : TMailMessage;
  I:integer;
begin
  try
    for I:=0 to Length(FDest)-1 do
    begin
      MailMsg :=TMailMessage.Create(FDest[I],FOrig[I]);
      try
        try
          MailMsg.SendNow;
        except
          on E:Exception do
          begin
            FErrMsg:=e.Message+#$D#$A'系统忽略该邮件,尝试发送下一封邮件.';
            Synchronize(DoOnError);
            Continue;
          end;
        end;
      finally
        MailMsg.Free;
      end;
    end;
    Synchronize(DoOnComplete);
  except
    on E:Exception do
    begin
      FErrMsg:=e.Message;
      Synchronize(DoOnError);
    end;
  end;
end;
{ TEmailQueue }
constructor TEmailQueue.Create;
begin
  Inherited;
  List:=TEmailInfoList.Create;
end;
destructor TEmailQueue.Destroy;
begin
  List.free;
  inherited;
end;
function TEmailQueue.GetCount: integer;
begin
  result:=List.Count;
end;
function TEmailQueue.Peek: TEmailInfo;
begin
  Result := TEmailInfo(inherited Peek);
end;
function TEmailQueue.Pop: TEmailInfo;
begin
  Result := TEmailInfo(inherited Pop);
end;
procedure TEmailQueue.Push(Email: TEmailInfo);
var
  AEmail: TEmailInfo;
begin
  AEmail:=TEmailInfo.Create;   //不用在这里释放
  AEmail.Assign(Email);
  inherited Push(Pointer(AEmail));
end;
{ TEmailInfoList }
procedure TEmailInfoList.Notify(Ptr: Pointer; Action: TListNotification);
begin
  case Action of
    lnAdded:;
    lnExtracted:;
    lnDeleted:
      if Ptr<>nil then TEmailInfo(Ptr).Free;
  end;
end;
{ TEmailSenderMgr }
constructor TEmailSenderMgr.Create;
begin
  FQueue:=TEmailQueue.Create;
  FCS:=TCriticalSection.Create;
  FThreadMailMessage:=nil;
  FIsSending:=False;
  FWindowHandle := AllocateHWnd(WndProc);
end;
destructor TEmailSenderMgr.Destroy;
begin
  FCS.Leave;
  FCS.Free;
  FQueue.Free;
  CloseHandle(FWindowHandle);
  inherited;
end;
procedure TEmailSenderMgr.DoOnError(Sender: TObject; Msg: String);
begin
  if Assigned(FOnError) then FOnError(self,FQueue.Peek,Msg)
end;
function TEmailSenderMgr.HasEmail: Boolean;
begin
  Result:=FQueue.AtLeast(1);
end;
procedure TEmailSenderMgr.MyOnComplete(Sender: TObject);
begin
  if FQueue.Count=1 then
    SendMessage(FWindowHandle,WM_Complete,0,0)
  else
  begin
    SendMessage(FWindowHandle,WM_OneSendEnd,0,0);
    if Assigned(FOneSendEnd) then FOneSendEnd(Self,FQueue.Peek);
  end;
  FQueue.Pop; //对象释放
end;
function TEmailSenderMgr.Peek: TEmailInfo;
begin
  FCS.Enter;
  Result:=FQueue.Peek;
  FCS.Leave;
end;
function TEmailSenderMgr.Pop: TEmailInfo;
begin
  FCS.Enter;
  Result:=FQueue.Pop;
  FCS.Leave;
end;
procedure TEmailSenderMgr.Push(Email: TEmailInfo);
begin
  FCS.Enter;
  FQueue.Push(Email);
  FCS.Leave;
end;
procedure TEmailSenderMgr.Send;
begin
  SendMessage(FWindowHandle,WM_Begin,0,0);
end;
procedure TEmailSenderMgr.WndProc(var Msg: TMessage);
begin
  case Msg.Msg of
    WM_Begin:
      if HasEmail then
      begin
        if FIsSending=true then exit;
        FIsSending:=true;
        //为什么用peek，因为pop时对象就被释放了
        FThreadMailMessage:=TThreadMailMessage.Create(FQueue.Peek.Recv,FQueue.Peek.Send);
        SendMessage(FWindowHandle,WM_OneSendBegin,0,0);
        FThreadMailMessage.OnSendComplete:=MyOnComplete;
        FThreadMailMessage.OnSendError:=DoOnError;
        FThreadMailMessage.Resume;
      end;
      
    WM_OneSendBegin:
      if Assigned(FOnOneSend)  then FOnOneSend(self,FQueue.Peek);
    WM_OneSendEnd:
    begin
     //为什么用peek，因为pop时对象就被释放了
      FThreadMailMessage:=TThreadMailMessage.Create(FQueue.Peek.Recv,FQueue.Peek.Send);
      FThreadMailMessage.OnSendComplete:=MyOnComplete;
      FThreadMailMessage.OnSendError:=DoOnError;
      FThreadMailMessage.Resume;
    end;
    WM_Complete:
    begin
      FIsSending:=false;
      if Assigned(FOneSendEnd) then FOneSendEnd(Self,FQueue.Peek);
      if Assigned(FOnComplete) then  FOnComplete(self);
    end;
  end;
end;
{ TEmailInfo }
procedure TEmailInfo.AssignTo(Dest: TPersistent);
begin
  if Dest is  TEmailInfo then
  begin
    Frecv.AssignTo(TEmailInfo(Dest).Recv);
    FSend.AssignTo(TEmailInfo(Dest).Send);
    TEmailInfo(Dest).IsError:=IsError;
    TEmailInfo(Dest).Id:=id;
  end
  else
  Inherited;
end;
constructor TEmailInfo.Create;
begin
  Frecv:=TDestinationPart.create('','','','','','',nil);
  FSend:=TOriginPart.Create(atSASL,'','','','',25);
end;
destructor TEmailInfo.Destroy;
begin
  if Frecv<>nil then Frecv.Free;
  if FSend<>nil then FSend.Free;
  inherited;
end;
procedure TEmailInfo.SetFRecv(const Value: TDestinationPart);
begin
  FRecv.Assign(Value);
end;
procedure TEmailInfo.SetSend(const Value: TOriginPart);
begin
  FSend.Assign(Value);
end;
end.

						