Email服务器

开发平台：
Delphi

uRecvEmail.pas：源码内容
							unit uRecvEmail;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Forms,Mail2000,
    uRulerMgr,IniFiles,uCommon;
type
  TOnErrorEvent=procedure (Sender:TObject;ErrMsg:string)of object;
  TOnAttachFileRetrieveed=procedure (sender:TObject; FileName:string;FileStream:TMemoryStream;FCurNum,FTotal:Integer)of object;
  TOnRetrieveed=procedure (sender:TObject;FCurNum,FTotal:Integer;UIDL:string)of object;
  TOnGetUIDL=procedure (sender:TObject;UIDL:String;var Handle:Boolean) of object;
  TOnFilter=procedure (Sender:TObject;Action:TRuleAction;EmailSubject:string;EmailFrom:string;var DeleteIt:Boolean;var Ignore:Boolean) of object;
  TRecvEmail=class(TThread)
  private
    Fpop:TPOP2000;
    FMsg:TMailMessage2000;
    
    FFilter:TRuleItems; //过滤规则
    Fcont:TMemoryStream;
    
    FUIDL:String;
    
    FAction:TRuleAction;
    FPop3LoginInfo:array of TPop3LoginInfo;
    FOnComplete:TNotifyEvent;
    FOnFilter:TOnFilter;
    FOnGetUIDL:TOnGetUIDL;
    FBeginWork,
    FEndWork:TNotifyEvent;
    
    FHandle:Boolean;   //是否继续处理该邮件
    FDeleteAfterRecv:Boolean;
    FIsBusy:Boolean;
    FFileName:string;
    FFilterDelete:Boolean;
    FFilterIgnore:Boolean;
    FRecvEMailProgress,
    FRecvMsgProgress:TProgressEvent;
    FOnError:TOnErrorEvent;
    FTotal1,FTotal2,
    FCurrent1,FCurrent2:Integer;
    FEMailTotal,
    FEMailCur,
    FAttchTotal,
    FAttchCur:Integer;
    
    FErrorMsg:string;
    FRetrieveAllMessage:Boolean;
    FRetrieveMessageNum:Integer;
    FOnRetrieveed:TOnRetrieveed;
    FOnAttachFileRetrieveed:TOnAttachFileRetrieveed;
    FBlackList,
    FWhiteList:TStrings; //黑名单， 白名单
    procedure SetFilter(const Value: TRuleItems);
    procedure SetBlackList(const Value: TStrings);
    procedure SetWhiteList(const Value: TStrings);
  protected
    procedure myEmailProgress(Sender: TObject; Total, Current: Integer);
    procedure MyMsgProgress(Sender: TObject; Total, Current: Integer);
    procedure DoEmailPrpgress;
    procedure DoMsgProgress;
    procedure DoOnError;
    procedure DoOnRetrieveed;
    procedure DoOnAttachFileRetrieveed;
    procedure DoOnComplete;
    procedure DoOnGetUIDL;
    procedure DoFilter;
    procedure DoBeginWork;
    procedure DoEndWork;
    procedure Decode(var Strm:TMemoryStream);
    procedure Execute;override;
    procedure ExtractFileContent(var Content:string);
    function Filtered:Boolean;virtual;  //是否过滤该邮件
    function FilteredByWhiteList:Boolean;
    function FilteredByBlackList:Boolean;
  public
    constructor Create(APop3Server,AUserName,APassword:string);overload;
    constructor Create(const S:array of string);overload;
    destructor Destroy;override;
    function EmailConut:Integer;
    property OnRecvEMailProgress:TProgressEvent read FRecvEMailProgress write FRecvEMailProgress;
    property OnRecvMsgProgress:TProgressEvent  read FRecvMsgProgress write FRecvMsgProgress;
    property OnError:TOnErrorEvent  read FOnError write FOnError;
    property  OnRetrieveed:TOnRetrieveed  read FOnRetrieveed write FOnRetrieveed;
    property  OnAttachFileRetrieveed:TOnAttachFileRetrieveed read FOnAttachFileRetrieveed write FOnAttachFileRetrieveed;
    property  OnComplete:TNotifyEvent  read FOnComplete write FOnComplete;
    property  OnGetUIDL:TOnGetUIDL  read FOnGetUIDL write FOnGetUIDL;
    property OnFilter:TOnFilter read FOnFilter write FOnFilter;
    property  BeginWork:TNotifyEvent  read FBeginWork write FBeginWork;
    property  EndWork:TNotifyEvent  read FEndWork write FEndWork;
    
    property  RetrieveAllMessage:Boolean  read FRetrieveAllMessage write FRetrieveAllMessage default False;
    property RetrieveMessageNum:Integer  read FRetrieveMessageNum write FRetrieveMessageNum default 1;
    property DeleteAfterRecv:Boolean  read FDeleteAfterRecv write FDeleteAfterRecv default False;
    property  IsBusy:Boolean  read FIsBusy write FIsBusy default False;
    property  Pop3:TPOP2000  read Fpop ;
    property  Filter:TRuleItems read FFilter write SetFilter;
    property  BlackList:TStrings  read FBlackList write SetBlackList;
    property WhiteList:TStrings  read FWhiteList write SetWhiteList;
  end;
  
  //加入新邮件到来时，使用UIDL接受邮件。
  TRecvEmailExt=class(TRecvEmail)  
  private
     FNewEmailUIDLS:TStrings;
    procedure SetNewEmailUIDLS(const Value: TStrings);
  protected
    procedure Execute;override;
  public
    constructor Create;
    destructor Destroy;override;
    property NewEmailUIDLS:TStrings read FNewEmailUIDLS write SetNewEmailUIDLS;
  end;
implementation
uses  uEncrypt,RegExpr;
{ TRecvEmail }
constructor TRecvEmail.Create(APop3Server,AUserName,APassword:string);
begin
  inherited Create(True);
  FBlackList:=THashedStringList.Create;
  FWhiteList:=THashedStringList.Create;
  SetLength(FPop3LoginInfo,1);
  FPop3LoginInfo[0].FPopServer:=APop3Server;
  FPop3LoginInfo[0].FUserName:=AUserName;
  FPop3LoginInfo[0].FPwd:=APassword;
  FFilterDelete:=False;
  FFilterIgnore:=False;
  FFileName:='';
  FFilter:=TRuleItems.Create;
  Self.FreeOnTerminate:=True;
end;
constructor TRecvEmail.Create(const S: array of string);
var
  I:Integer;
  List:TStrings;
begin
  inherited Create(True);
  FBlackList:=THashedStringList.Create;
  FWhiteList:=THashedStringList.Create;
  SetLength(FPop3LoginInfo,Length(S));
  List:=TStringList.Create;
  try
    for I:=0 to Length(S)-1 do
    begin
      Split(';',S[I],List);
      FPop3LoginInfo[I].FPopServer:=List[0];
      FPop3LoginInfo[I].FUserName:=List[1];
      FPop3LoginInfo[I].FPwd:=List[2];
    end;
  finally
    List.Free;
  end;
  FFilterDelete:=False;
  FFilterIgnore:=False;
  FFileName:='';
  FFilter:=TRuleItems.Create;
  Self.FreeOnTerminate:=True;
end;
procedure TRecvEmail.Decode(var Strm:TMemoryStream);
var
  MIME:TMIMECipher;
begin
  MIME:=TMIMECipher.Create;
  try
    MIME.DecodeStream(Strm);
  finally
    MIME.Free;
  end;
end;
destructor TRecvEmail.Destroy;
begin
  FWhiteList.Free;
  FBlackList.Free;
  Filter.Free;
  inherited;
end;
procedure TRecvEmail.DoBeginWork;
begin
  if Assigned(FBeginWork) then FBeginWork(self);
end;
procedure TRecvEmail.DoEmailPrpgress;
begin
  if Assigned(FRecvEMailProgress)  then FRecvEMailProgress(self,FTotal1,FCurrent1) ;
end;
procedure TRecvEmail.DoEndWork;
begin
  if Assigned(FEndWork) then FEndWork(self);
end;
procedure TRecvEmail.DoFilter;
begin
  if Assigned(FOnFilter) then FOnFilter(Self,FAction,Fpop.MailMessage.Subject,Fpop.MailMessage.FromAddress,FFilterDelete,FFilterIgnore);
end;
procedure TRecvEmail.DoMsgProgress;
begin
  if Assigned(FRecvMsgProgress)  then FRecvMsgProgress(self,FTotal2,FCurrent2) ;
end;
procedure TRecvEmail.DoOnAttachFileRetrieveed;
begin
  if Assigned(FOnAttachFileRetrieveed)  then FOnAttachFileRetrieveed(Self,FFileName,Fcont,FAttchCur,FAttchTotal);
end;
procedure TRecvEmail.DoOnComplete;
begin
  if Assigned(Foncomplete) then Foncomplete(Self);
end;
procedure TRecvEmail.DoOnError;
begin
  if Assigned(FonError)  then FonError(self,FErrorMsg) ;
end;
procedure TRecvEmail.DoOnGetUIDL;
begin
  FHandle:=False;
  if Assigned(FOnGetUIDL) then FOnGetUIDL(Self,FUIDL,FHandle);
end;
procedure TRecvEmail.DoOnRetrieveed;
begin
  if Assigned(FOnRetrieveed) then FOnRetrieveed(Self,FEMailCur,FEMailTotal,FUIDL);
end;
function TRecvEmail.EmailConut: Integer;
begin
  //
  Result:=0;
end;
procedure TRecvEmail.Execute;
var
  EMailCount,I,J:Integer;
  
  procedure  RecvAttch;
  var
    J:Integer;
    S:string;
  begin
    if Fpop.MailMessage.AttachList.Count>0 then
    begin
      FAttchTotal:=Fpop.MailMessage.AttachList.Count;
      if FAttchTotal>0 then
      for J:=0 to FAttchTotal-1 do
      begin
        FAttchCur:=J+1;
        S:=Fpop.MailMessage.AttachList[J].PartSource;
        Fpop.MailMessage.Decode;
        FFileName:=Fpop.MailMessage.AttachList[J].FileName;
        Fcont:=TMemoryStream.Create;
        try
          Fcont.Position:=0;
          Fpop.MailMessage.AttachList[J].Body.SaveToStream(Fcont);
          Decode(Fcont);
          if Self.Terminated then Exit;
          Synchronize(DoOnAttachFileRetrieveed);
          if Self.Terminated then Exit;
        finally
          Fcont.Free;
        end;
      end;
    end;
  end;
  procedure ErrorNotify(Err:string);
  begin
    FErrorMsg:=Err;
    if not Fpop.Quit then Fpop.Abort;
    Synchronize(DoOnError);
  end;
begin
  IsBusy:=True;
  Fpop:=TPOP2000.Create(nil);
  FMsg:=TMailMessage2000.Create(nil);
  Fpop.MailMessage:=FMsg;
  Fpop.OnProgress:=myEmailProgress;
  Fpop.MailMessage.OnProgress:=MyMsgProgress;
  Fpop.DeleteOnRetrieve:=DeleteAfterRecv;
  Fpop.TimeOut:=65;
  Synchronize(DoBeginWork);
  try
    for J:=0 to Length(FPop3LoginInfo)-1 do
    begin
      Fpop.Host:=FPop3LoginInfo[J].FPopServer;
      Fpop.UserName:=FPop3LoginInfo[J].FUserName;
      Fpop.Password:=FPop3LoginInfo[J].FPwd;
      try
        try
          if not Fpop.Connect then
            ErrorNotify('无法连接pop3服务器')
          else
          begin
            if Self.Terminated then Exit;
            if not Fpop.Login  then
              ErrorNotify('无法登录pop3服务器')
            else
            begin
              EMailCount:=Fpop.SessionMessageCount;
              if EMailCount <1 then
              begin
                FErrorMsg:='邮箱中没有邮件';
                Synchronize(DoOnError);
                Exit;
              end;
              if Self.Terminated then Exit;
              FEMailTotal:=EMailCount;
              if RetrieveAllMessage then
              begin
                 for I:=1 to EMailCount do
                 begin
                    FEMailCur:=I;
                    
                    if FilteredByWhiteList then continue;
                    if FilteredByBlackList then continue;
                    FFilterDelete:=False;
                    FFilterIgnore:=False;
                    Fpop.MailMessage.AttachList.Clear;
                    
                    FUIDL:=Fpop.GetUIDL(I);
                    Synchronize(DoOnGetUIDL);
                    if FHandle then Continue;
                    if not Fpop.RetrieveMessage(I)then
                    begin
                      FErrorMsg:=Format('无法接收第%D封邮件 ',[I]);
                      if not Fpop.Quit then Fpop.Abort;
                      if Self.Terminated then Exit;
                      Synchronize(DoOnError);
                      Exit;
                    end
                    else
                    begin
                      Fpop.MailMessage.FindParts;
                      if Filtered then  Synchronize(DoFilter); //如果匹配到过滤规则，则执行动作。
                      if FFilterDelete then  // 执行"删除"动作
                      begin
                        Fpop.DeleteMessage(I);
                        Continue;
                      end;
                      if FFilterIgnore then Continue; //执行 "忽略，不处理" 动作
                      Synchronize(DoOnRetrieveed);
                      if Self.Terminated then Exit;
                      RecvAttch;
                    end;
                    Fpop.MailMessage.AttachList.Clear;   //added by wp 2009-12-31
                    if Self.Terminated then Exit;
                 end;
              end
              else
              begin
                FEMailCur:=1;
                FUIDL:=Fpop.GetUIDL(RetrieveMessageNum);
                if FHandle then Exit;
                if not Fpop.RetrieveMessage(RetrieveMessageNum)then
                  ErrorNotify(Format('无法接收第%D封邮件',[RetrieveMessageNum]))
                else
                begin
                  Fpop.MailMessage.FindParts;
                  if Filtered then Synchronize(DoFilter);   
                  if FFilterDelete then
                  begin
                    Fpop.DeleteMessage(RetrieveMessageNum);
                    Continue;
                  end;
                  if FFilterIgnore then Continue;
                  Synchronize(DoOnRetrieveed);
                  if Self.Terminated then Exit;
                  RecvAttch;
                end;
                Fpop.MailMessage.AttachList.Clear;
                if Self.Terminated then Exit;
              end;
            end;
          end;
        except
          on E:Exception do  ErrorNotify(e.Message);
        end;
      finally
        FMsg.Free;
        Fpop.Free;
        IsBusy:=False;
      end;
    end;
    Synchronize(DoOnComplete);
  finally
    IsBusy:=False;
    Synchronize(DoEndWork);
  end;
end;
procedure TRecvEmail.ExtractFileContent(var Content: string);
var
  I:Integer;
  lst:TStringList;
begin
  I:=Pos(#$D#$A#$D#$A,Content);
  if I=0 then Exit;
  Delete(Content,1,I);
  lst:=TStringList.Create;
  try
    lst.DelimitedText:='#$D#$A';
    lst.Text:=Content;
    Content:='';
    for I:=0  to lst.Count-1 do
      Content:=Content+lst.Strings[I]
  finally
    lst.Free;
  end;
end;
function TRecvEmail.Filtered: Boolean;
var
  I,J:Integer;
  reg:TRegExpr;
  
  function FilterPart(Str:string):Boolean;
  begin
    Result:=False;
    case FFilter.Items[I].Rows[J].Compare of
      rcContains:
        if Pos(FFilter.Items[I].Rows[J].Text,Str)>0 then
          Result:=True;
      rcEquals:
        if CompareStr(FFilter.Items[I].Rows[J].Text,Str)=0 then
          Result:=True;
      rcEmpty:
          Result:=Str='';
      rcRegExpr:
      begin
        try
          reg.Expression:=FFilter.Items[I].Rows[J].Text;
          Result:= reg.Exec(Str);
        except
          //raise Exception.Create('正则表达式错误，无法匹配！');
        end;
      end;
    else ;
    end;
  end;
  
begin
  Result:=False;
  if FFilter=nil then Exit;
  
  reg:=TRegExpr.Create;
  try
    for I:=0 to FFilter.Count-1 do
    begin
      if not FFilter.Items[I].Enabled then  Continue; //该规则未被启用
      if not FFilter.Items[I].AllAccount then
        if CompareText(FFilter.Items[I].Account, Fpop.UserName)<>0 then Continue;//该规则只应用于本账号
      FAction:=FFilter.Items[I].RulerAction;
      for J:=0 to  FFilter.Items[I].Rows.Count-1 do   //该规则应用于所有账号
      begin
        if (not VarIsOrdinal(FFilter.Items[I].Rows[J].Area)) or (not VarIsOrdinal(FFilter.Items[I].Rows[J].Compare)) then Continue;
        if (FFilter.Items[I].Rows[J].Compare<>rcEquals) and (FFilter.Items[I].Rows[J].Text='') then Continue;
        case FFilter.Items[I].Rows[J].Area of
          raSubject:
          begin
            Result:=FilterPart(Fpop.MailMessage.Subject);
            if result then break;
          end;
          raTo:
          begin
            Result:=FilterPart(Fpop.MailMessage.ReceiptAddress);
            if result then break;
          end;
          raFrom:
          begin
            Result:=FilterPart(Fpop.MailMessage.FromAddress);
            if result then break;
          end;
          raCC:
          begin
            Result:=FilterPart(Fpop.MailMessage.CcList.AllAddresses);
            if result then break;
          end;
          raCB:
          begin
            Result:=FilterPart(Fpop.MailMessage.BCcList.AllAddresses);
            if result then break;
          end;
          raBody:
          begin
            Result:=FilterPart(Fpop.MailMessage.TextHtml.Text);
            if result then break;
          end;
          raHeader:
          begin
            Result:=FilterPart(Fpop.MailMessage.Header.Text);
            if result then break;
          end;
        else ;
        end;
      end
    end;
  finally
    reg.Free;
  end;
end;
function TRecvEmail.FilteredByBlackList: Boolean; //是否被白名单过滤掉了
begin
  result:=False;
  if BlackList.Count>0 then
  begin
    Fpop.RetrieveHeader(FEMailCur,20);
    if BlackList.IndexOf(UpperCase(Fpop.UserName))>-1 then Result:=True;  //在黑名单之内，不接收
  end;
end;
function TRecvEmail.FilteredByWhiteList: Boolean;
begin
  result:=WhiteList.Count>0 ;
  if result then
  begin
    Fpop.RetrieveHeader(FEMailCur,20);
    if WhiteList.IndexOf(UpperCase(Fpop.UserName))<>-1 then Result:=False;  //在白名单之内
  end
end;
procedure TRecvEmail.myEmailProgress(Sender: TObject; Total,
  Current: Integer);
begin
  FTotal1:=Total;
  FCurrent1:=Current;
  Synchronize(DoEmailPrpgress);
end;
procedure TRecvEmail.MyMsgProgress(Sender: TObject; Total,
  Current: Integer);
begin
  FTotal2:=Total;
  FCurrent2:=Current;
  Synchronize(DoMsgProgress);
end;
procedure TRecvEmail.SetBlackList(const Value: TStrings);
begin
  FBlackList.Assign(Value);
end;
procedure TRecvEmail.SetFilter(const Value: TRuleItems);
begin
  if FFilter<>Value then
    FFilter.Assign(Value);
end;
procedure TRecvEmail.SetWhiteList(const Value: TStrings);
begin
  FWhiteList.Assign(Value);
end;
{ TRecvEmailExt }
constructor TRecvEmailExt.Create;
begin
  inherited Create('','','');
  FNewEmailUIDLS:=TStringList.Create;
end;
destructor TRecvEmailExt.Destroy;
begin
  FNewEmailUIDLS.Free;
  inherited;
end;
procedure TRecvEmailExt.Execute;
var
 J:Integer;
  
  procedure  RecvAttch;
  var
    J:Integer;
    S:string;
  begin
    if Fpop.MailMessage.AttachList.Count<>0 then
    begin
      FAttchTotal:=Fpop.MailMessage.AttachList.Count;
      for J:=0 to FAttchTotal-1 do
      begin
        FAttchCur:=J+1;
        S:=Fpop.MailMessage.AttachList[J].PartSource;
        Fpop.MailMessage.Decode;
        FFileName:=Fpop.MailMessage.AttachList[J].FileName;
        Fcont:=TMemoryStream.Create;
        try
          Fcont.Position:=0;
          Fpop.MailMessage.AttachList[J].Body.SaveToStream(Fcont);
          Decode(Fcont);
          if Self.Terminated then Exit;
          Synchronize(DoOnAttachFileRetrieveed);
          if Self.Terminated then Exit;
        finally
          Fcont.Free;
        end;
      end;
    end;
  end;
  procedure ErrorNotify(Err:string);
  begin
    FErrorMsg:=Err;
    if not Fpop.Quit then Fpop.Abort;
    Synchronize(DoOnError);
  end;
begin
  IsBusy:=True;
  Fpop:=TPOP2000.Create(nil);
  FMsg:=TMailMessage2000.Create(nil);
  Fpop.MailMessage:=FMsg;
  Fpop.OnProgress:=myEmailProgress;
  Fpop.MailMessage.OnProgress:=MyMsgProgress;
  Fpop.DeleteOnRetrieve:=DeleteAfterRecv;
  Fpop.TimeOut:=65;
  Synchronize(DoBeginWork);
  try
    FEMailTotal:=NewEmailUIDLS.Count;
    for J:=0 to FEMailTotal -1 do
    begin
      if not Fpop.Quit then Fpop.Abort;
      Fpop.Host:=PPop3LoginInfo(NewEmailUIDLS.Objects[J]).FPopServer;
      Fpop.UserName:=PPop3LoginInfo(NewEmailUIDLS.Objects[J]).FUserName;
      Fpop.Password:=PPop3LoginInfo(NewEmailUIDLS.Objects[J]).FPwd;
      Fpop.Port:=PPop3LoginInfo(NewEmailUIDLS.Objects[J]).FPort;
      Dispose(PPop3LoginInfo(NewEmailUIDLS.Objects[J]));    //Free Memory ,these memory allocate in TCheckEmailThread class.
      try
        try
          if not Fpop.Connect then
            ErrorNotify('无法连接pop3服务器')
          else
          begin
            if Self.Terminated then Exit;
            if not Fpop.Login  then
              ErrorNotify('无法登录pop3服务器')
            else
            begin
              if Self.Terminated then Exit;
              if FilteredByWhiteList then continue;
              if FilteredByBlackList then continue;
              FFilterDelete:=False;
              FFilterIgnore:=False;
              Fpop.MailMessage.AttachList.Clear;
              FEMailCur:=J;
              if not Fpop.RetrieveMessage(StrToInt(PartStr(NewEmailUIDLS[J],#32)))then //////////////////////////
              begin
                FErrorMsg:=Format('无法接收第%D封邮件 ',[J]);
                if not Fpop.Quit then Fpop.Abort;
                if Self.Terminated then Exit;
                Synchronize(DoOnError);
                Exit;
              end
              else
              begin
                Fpop.MailMessage.FindParts;
                if Filtered then  Synchronize(DoFilter); //如果匹配到过滤规则，则执行动作。
                if FFilterDelete then  // 执行"删除"动作
                begin
                  Fpop.DeleteMessage(StrToInt(PartStr(NewEmailUIDLS[J],#32)));
                  Continue;
                end;
                if FFilterIgnore then Continue; //执行 "忽略，不处理" 动作
                Synchronize(DoOnRetrieveed);
                if Self.Terminated then Exit;
                RecvAttch;
              end;
              if Self.Terminated then Exit;
            end;
          end;;
        except
          on E:Exception do  ErrorNotify(e.Message);
        end;
      finally
        if  FMsg<>nil then
        begin
          FMsg.Free;
          FMsg:=nil;
        end;
        Fpop.Free;
      end;
    end;
    Synchronize(DoOnComplete);
  finally
    IsBusy:=False;
    Synchronize(DoEndWork);
  end;
end;
procedure TRecvEmailExt.SetNewEmailUIDLS(const Value: TStrings);
begin
  if FNewEmailUIDLS<>Value then
    FNewEmailUIDLS.Assign(Value);
end;
end.

						