unit uSendMail;interfaceuses Classes,SysUtils,Dialogs, windows,IdMessage, IdEmailAddress,IdSMTP, IdAttachmentFile, IdText, IdSASL_CRAM_MD5,IdUserPassProvider,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; TOnProgress=procedure (Sender:TObject;Total,Current:int64) of object; TThreadMailMessage = class(TBaseThreadMailMessage) private //FTotal,FCurrent:int64; //FOnSendProgress:TOnProgress; protected MailMsg : TMailMessage; //procedure DoOnProgress; 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;implementationuses 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; //SMTP.OnWorkBegin:=OnWorkBegin; //Smtp.OnWork:=OnWork; //SMTP.OnWorkEnd:=OnWorkEnd; {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);beginend;procedure TOriginPart.SaveToFile(fn:string);beginend;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:=TDestinationPart.Create; FDest.Assign(aDestinationPart); end; SetLength(FOrig,Length(aOriginPart)); //CopyMemory(@FOrig[0],@aOriginPart[0],sizeof(TOriginPart)*Length(aOriginPart)); for I:=0 to Length(aOriginPart)-1 do begin FOrig:=TOriginPart.Create; FOrig.Assign(aOriginPart); end;end;destructor TMultiThreadMailMessage.Destroy;var I:integer;begin for I:=0 to Length(FOrig)-1 do begin FDest.Free; FOrig.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,FOrig); 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时对象就被释放了 with FQueue.Peek do FThreadMailMessage:=TThreadMailMessage.Create(Recv,Send); SendMessage(FWindowHandle,WM_OneSendBegin,0,0); FThreadMailMessage.OnSendComplete:=MyOnComplete; FThreadMailMessage.OnSendError:=DoOnError; //FThreadMailMessage.OnSendProgres:=self.OnOneSendProgress; 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.
