uSendMail.pas
上传用户:yjb1804
上传日期:2021-01-30
资源大小:3105k
文件大小:18k
- 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.