unitmailserver.pas

Mailserver Source code - Delphi. Simple Mail server source code. SMTP and POP3 protocols.

unit UnitMailServer;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, Messages, SysUtils, Classes, ComServ, ComObj, VCLCom, DataBkr,registry,Tlhelp32,MailProcessUnit,
  DBClient, server_TLB, StdVcl, DB, ADODB, Provider,unit_inifiles,forms,dialogs,dataint_TLB,SHELLAPI,filesys_TLB;

type
  TMailServer = class(TRemoteDataModule, IMailServer)
    ADOConnection1: TADOConnection;
    Ads_User: TADODataSet;
    Dsp_User: TDataSetProvider;
    Ads_Domain: TADODataSet;
    Dsp_Domain: TDataSetProvider;
    Ads_Temp: TADODataSet;
    Ds_Temp: TDataSource;
    Ads_Clean: TADODataSet;
    Dsp_Clean: TDataSetProvider;
    Ads_Pass: TADODataSet;
    Dsp_Pass: TDataSetProvider;
    Ads_RUMail: TADODataSet;
    Dsp_RUMail: TDataSetProvider;
    Ads_Receive: TADODataSet;
    Dsp_Receive: TDataSetProvider;
    Ads_trash: TADODataSet;
    Dsp_trash: TDataSetProvider;
    Ads_UserDetail: TADODataSet;
    Dsp_UserDetail: TDataSetProvider;
    procedure RemoteDataModuleCreate(Sender: TObject);
  private
    { Private declarations }
    FExecPath,FADMINMAIL:string;
    FComForSmtp:IComForSmtp;     //smtp接口
    FComForFileSys: IComForFileSys;  //文件系统接口

    FReplyState,FMailID,FMailBox,FUserMail:string;
    //读取日志
    FLogTag:string;
    //操作用户
    FUsersDomain:string;
    //////////////////////////////////////////////////////////
    procedure TermProcess(strLExeFileName:String);
    function  GetUserIDListInOneDomain(ADomain:string):String;
    {---------系统信息------------}
    function  GetSysInfomation:string;
    function  GetCpuType :string;
    function  GetWinVersion :string;
    function  GetWindowsPath :string;
    function  GetPhyMemery :string;
    function  GetServerComputerName :string;
    function  GetMetrics:string;
    function  GetDriverNum :string;
    function  DiskInDrive(Drive: Char): Boolean;
    {--------发送广播--------------}
    procedure AddEmailToOneUser(AUserID,AMailFrom, ASubject,AContent: WideString);
    function  GetUserIDMail(AUserID:string):String;
    {--------系统清理--------------}
    function  DelDirectory(const Source:string): boolean;
    procedure DeleteMailFile(ARootPath,ASubPath:string);
    {--------读取邮件--------------}
  protected
    class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
    procedure BroadCastEmail(const ADomain, AdminEmail, EmailSubject,
      EmailContent: WideString); safecall;
    function Get_MailData: WideString; safecall;
    procedure Set_ReplyState(const Value: WideString); safecall;
    procedure Set_MailID(const Value: WideString); safecall;
    procedure Set_MailBox(const Value: WideString); safecall;
    procedure Set_UserMail(const Value: WideString); safecall;
    function Get_GetLog: WideString; safecall;
    procedure Set_SetLogTag(const Value: WideString); safecall;
    function Get_GetInfo: WideString; safecall;
    function Get_GetConfigInfo: WideString; safecall;
    procedure Set_SetconfgInfo(const Value: WideString); safecall;
    procedure ResetServer; safecall;
    procedure CleanDeletedMail; safecall;
    procedure CleanLog; safecall;
    procedure CleanFailedMail; safecall;
    procedure CleanRelyedMail; safecall;
    procedure ClearUserOtherInfo(const AUserID, ADomain: WideString); safecall;
    procedure Set_SetUsersDomain(const Value: WideString); safecall;
    procedure SendWelcomMail(const AUserID: WideString); safecall;

  public
    { Public declarations }

  end;

implementation

uses FrmMain;

{$R *.DFM}

class procedure TMailServer.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
begin
  if Register then
  begin
    inherited UpdateRegistry(Register, ClassID, ProgID);
    EnableSocketTransport(ClassID);
    EnableWebTransport(ClassID);
  end else
  begin
    DisableSocketTransport(ClassID);
    DisableWebTransport(ClassID);
    inherited UpdateRegistry(Register, ClassID, ProgID);
  end;
end;

//初始化------------------------------------------------------------------------
procedure TMailServer.RemoteDataModuleCreate(Sender: TObject);
var
  myinifile:Tinifile;//ini文件
  ConStr:String;
begin
  FExecPath:=extractfilepath(application.ExeName);
  myinifile:=Tinifile.Create(FExecPath+'config.ini');
  try
    //设置连接参数
    FADMINMAIL:=myinifile.ReadString('MAILBOX','ADMINMAIL','admin@MainDomain');
    ConStr :=myinifile.ReadString('CONFIG','DATA','');
    myinifile.FComFomDes.DecCodeString(ConStr,'www.szstartdot.com');
    ADOConnection1.ConnectionString:=wideString(myinifile.FComFomDes.GetCode);
    //初始化smtp接口
    FComForSmtp:=CoComForSmtp.Create;
    FComForSmtp.Create(FExecPath);
    FComForFileSys:=CoComForFileSys.Create; //初始化com接口
    FComForFileSys.Create(FExecPath);
  finally
    myinifile.Free;
  end;
end;
//------------------------------------------------------------------------------
function TMailServer.Get_GetConfigInfo: WideString;
begin
end;

procedure TMailServer.Set_SetconfgInfo(const Value: WideString);
begin
end;

procedure TMailServer.ResetServer;
var
  MyExePath:string;
begin
  TermProcess('mail.exe');
  MyExePath:=FExecPath+'mail.exe';
  ShellExecute(application.handle,nil,pchar(MyExePath),nil,nil,sw_shownormal);
end;

//终止进程
procedure TMailServer.TermProcess(strLExeFileName:String);
const
  PROCESS_TERMINATE=$0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
try
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle,FProcessEntry32);
  while integer(ContinueLoop) <> 0 do
  begin
   if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
         UpperCase(strLExeFileName))
     or (UpperCase(FProcessEntry32.szExeFile) =
         UpperCase(strLExeFileName))) then
      TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0),FProcessEntry32.th32ProcessID), 0);
    ContinueLoop := Process32Next(FSnapshotHandle,FProcessEntry32);
  end;
except
end;
end;
{-------------------------------------------------------------------------------
+                      start 用户管理                                          +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}
procedure TMailServer.SendWelcomMail(const AUserID: WideString);
var
  MyList:TStringList;
  MyPath,MySubject,MyContent:string;
begin
  MyPath:=FExecPath+'welcome.dat';
  MyList:=TStringList.Create;
  try
    if fileexists(MyPath) then
    begin
      MyList.LoadFromFile(MyPath);
      if  MyList.Count<>0 then
      begin
        MySubject:=MyList.Strings[0];
        MyList.Delete(0);
        MyContent:=MyList.Text;
      end
      else begin
        MySubject:='欢迎使用';
        MyContent:='欢迎使用';
      end;
    end
    else begin
      MySubject:='欢迎使用';
      MyContent:='欢迎使用';
    end;
    AddEmailToOneUser(AUserID,FADMINMAIL, MySubject,MyContent);
  finally
    MyList.Free;
  end;
end;

//删除某个用户的email文件夹
procedure TMailServer.ClearUserOtherInfo(const AUserID,
  ADomain: WideString);
var
  RecPath,ReplyPath:string;
begin
  try
    RecPath:=FExecPath+'receive\'+AUserID+'@'+ADomain;
    ReplyPath:=FExecPath+'reply\'+AUserID+'@'+ADomain;
    DelDirectory(RecPath);
    DelDirectory(ReplyPath);
  finally
  end;
end;

{-------------------------------------------------------------------------------
+                      end   用户管理                                          +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}

{-------------------------------------------------------------------------------
+                  start     获取用户的详细使用信息                            +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}
//设置所属域名
procedure TMailServer.Set_SetUsersDomain(const Value: WideString);
begin
  FUsersDomain:=Value;
end;

//获得某个域名的用户列表
function TMailServer.GetUserIDListInOneDomain(ADomain:string):String;
var
  MyList:TStringList;
begin
  MyList:=TStringList.Create;
  result:='';
  try
    with Ads_Temp do
    begin
      Close;
      CommandText:='select USERID from USERINFO_VIEW where DOMAINNAME='''+ADomain+'''';
      Open;
    end;
    with Ds_Temp.DataSet do
    begin
      while Eof=false do
      begin
        MyList.Add(Fields[0].AsString);
        Next;
      end;
    end;
    result:=MyList.Text;
  finally
    MyList.Free;
  end;
end;

//获得某个域名的用户列表
function TMailServer.GetUserIDMail(AUserID:string):String;
begin
  try
    with Ads_Temp do
    begin
      Close;
      CommandText:='select USERIDNAME,DOMAINNAME from USERINFO_VIEW where USERID='''+AUserID+'''';
      Open;
    end;
    with Ds_Temp.DataSet do
    begin
      if  Eof=false then
      begin
        result:=Fields[0].AsString+'@'+Fields[1].AsString;
      end;
    end;
  finally
  end;
end;
{-------------------------------------------------------------------------------
+                  end     获取用户的详细使用信息                              +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}

{-------------------------------------------------------------------------------
+                  start     系统信息                                          +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}
function TMailServer.Get_GetInfo: WideString;
begin
  result:=GetSysInfomation;
end;

//计算机信息--------
function TMailServer.GetSysInfomation:string;
var
  MyList:TstringList;
  Tmpstr:string;
  i:integer;
begin
  MyList:=TstringList.Create;
  try
    MyList.Add(FExecPath);
    MyList.Add(GetCpuType);
    MyList.add(GetWinVersion);
    MyList.add(GetWindowsPath);
    MyList.add(GetPhyMemery);
    MyList.add(GetServerComputerName);
    MyList.add(GetMetrics);
    Tmpstr:=GetDriverNum;
    for i:=1 to length(Tmpstr) do
    begin
       MyList.add(Tmpstr[i]+':盘驱动器容量%%%'+floattostr(disksize(ord(Tmpstr[i])-$20)/1000000)+'MB');
       MyList.add(Tmpstr[i]+':盘驱动器剩余容量%%%'+floattostr(diskfree(ord(Tmpstr[i])-$20)/1000000)+'MB');
    end;
    result:=MyList.Text;
  finally
    MyList.Free;
  end;
end;
//---------
function TMailServer.GetCpuType :string;
var sysinfo:system_info;
    str,str1:string;
begin
  GetSystemInfo(sysinfo);
  str:='系统有'+inttostr(sysinfo.dwNumberOfProcessors)+'个CPU  ';
  case sysinfo.dwProcessorType of
       386:str1:='类型为386';
       486:str1:='类型为486';
       586:str1:='类型为Pentium';
       end;