unitmailserver.pas

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

  Result :=str+str1;
end;
//--------
function TMailServer.GetWinVersion :string;
var osvi:OSVERSIONINFO;
begin
  osvi.dwOSVersionInfoSize :=sizeof(osversioninfo);;
  getversionex(osvi);
  case osvi.dwPlatformId of
       VER_PLATFORM_WIN32s:result:='Windows 3.1';
       VER_PLATFORM_WIN32_NT :result:='Windows NT';
       VER_PLATFORM_WIN32_WINDOWS :result:='Windows 9x';
       end;
end;
//--------
function TMailServer.GetWindowsPath :string;
var sysdir:array [0..255] of char;
begin
  GetWindowsDirectory(sysdir,255);
  Result :=sysdir;
end;
//----------
function TMailServer.GetPhyMemery :string;
var meminfo:memorystatus;
begin
  meminfo.dwLength :=sizeof(memorystatus);
  GlobalMemoryStatus(meminfo);
  Result :=inttostr(meminfo.dwTotalPhys div 1024)+'KB';
end;
//--------
function TMailServer.GetServerComputerName :string;
var temp:pchar;
    size:DWord;
begin
   getmem(temp,255);
   size:=255;
   if GetComputerName(temp,size)=false then
     begin
       freemem(temp);
       exit;
     end;
   result:=temp;
   freemem(temp);
end;
//-----
function TMailServer.GetMetrics:string;
begin
  Result :=inttostr(GetSystemMetrics(SM_CXSCREEN))
    +'X'+inttostr(GetSystemMetrics(SM_CYSCREEN));
end;
//--------
function TMailServer.GetDriverNum :string;
var i:Char;
begin
  result:='';
  for i:='C' to 'Z' do
    begin
      if DiskInDrive(i) then
        result:=result+i;
    end;
end;
//-----
function TMailServer.DiskInDrive(Drive: Char): Boolean;
var ErrorMode: word;
begin
   if Drive in ['a'..'z'] then Dec(Drive, $20);
   if not (Drive in ['A'..'Z']) then
   raise EConvertError.Create('Not a valid drive ID');
   ErrorMode := SetErrorMode(SEM_FailCriticalErrors);
   try
     if DiskSize(Ord(Drive) - $40) = -1 then
     Result := False
   else
     Result := True;
   finally
     SetErrorMode(ErrorMode);
   end;
end;

{-------------------------------------------------------------------------------
+                    end     系统信息                                          +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}

{-------------------------------------------------------------------------------
+                    start 发送广播                                            +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}
//发送email
procedure TMailServer.BroadCastEmail(const ADomain, AdminEmail,
  EmailSubject, EmailContent: WideString);
var
  MyUserList,MyDomainList:TStringList;
  i,j:integer;
begin
  MyUserList:=TStringList.Create;
  MyDomainList:=TStringList.Create;
  try
    MyDomainList.Text:=ADomain;
    for i:=0 to  MyDomainList.Count-1 do
    begin
      MyUserList.Text:=GetUserIDListInOneDomain(MyDomainList.Strings[i]);
      for j:=0 to MyUserList.Count-1 do
      begin
        AddEmailToOneUser(MyUserList.Strings[j],AdminEmail,EmailSubject,EmailContent);
      end;
    end;
  finally
    MyUserList.Free;
    MyDomainList.free;
  end;
end;

//向某一个用户发信
procedure TMailServer.AddEmailToOneUser(AUserID,AMailFrom, ASubject,AContent: WideString);
var
  CoolMailMessage:TCoolMailMessage;
  MyRcptTo:string;
begin
  CoolMailMessage:=TCoolMailMessage.Create(nil);
  try
    MyRcptTo:=GetUserIDMail(AUserID);
    if  MyRcptTo<>'' then
    begin
      CoolMailMessage.SetFrom(AMailFrom,AMailFrom);
      CoolMailMessage.AddSendTo(MyRcptTo,MyRcptTo);
      CoolMailMessage.Subject:=ASubject;
      CoolMailMessage.CharSet:='GB2312';
      CoolMailMessage.MailBody.Text:=AContent;
      CoolMailMessage.GenarateMailBuffer;
      FComForSmtp.MailFrom:=AMailFrom;          //设置发信人地址
      FComForSmtp.ReplyState:='0';
      FComForSmtp.RcptTo:=MyRcptTo;      //设置返回email的地址
      FComForSmtp.AddtoRcptToList;


      FComForSmtp.AddNewMail(CoolMailMessage.MailBuffer.Text);

    end;
  finally
  end;
end;
{-------------------------------------------------------------------------------
+                    end 发送广播                                              +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}

{-------------------------------------------------------------------------------
+                    start 系统清理                                            +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}
procedure TMailServer.CleanDeletedMail;
var
  BoxName:string;
begin
  FComForFileSys.RelyState:='0';
  FComForFileSys.BoxIndex:='5';
  BoxName:=FComForFileSys.GetConvBoxName;
  DeleteMailFile(FExecPath+'receive\',BoxName);
end;

procedure TMailServer.CleanLog;
begin
  deletefile(FExecPath+'logs\pop3.log');
  deletefile(FExecPath+'logs\reply.log');
  deletefile(FExecPath+'logs\smtp.log');
  deletefile(FExecPath+'logs\system.log');
end;

procedure TMailServer.CleanFailedMail;
var
  BoxName:string;
begin
  FComForFileSys.RelyState:='1';
  FComForFileSys.BoxIndex:='3';
  BoxName:=FComForFileSys.GetConvBoxName;
  DeleteMailFile(FExecPath+'reply\',BoxName);
end;

procedure TMailServer.CleanRelyedMail;
var
  BoxName:string;
begin
  FComForFileSys.RelyState:='1';
  FComForFileSys.BoxIndex:='32';
  BoxName:=FComForFileSys.GetConvBoxName;
  DeleteMailFile(FExecPath+'reply\',BoxName);
end;

procedure TMailServer.DeleteMailFile(ARootPath,ASubPath:string);
var
  retval:integer;
  SRec: TSearchRec;
begin
  try
    retval := FindFirst(ARootPath+'*.*',faAnyFile,SRec);
    While retval=0 Do
    begin
      If ((SRec.Attr or faDirectory) <> 0)  Then
      begin
        if (SRec.Name<>'.') and (SRec.Name<>'..') then
        begin
          DelDirectory(ARootPath+SRec.Name+'\'+ASubPath);
        end;
      end;
      retval:= FindNext(SRec);
    end;
    SysUtils.FindClose(SRec);
  finally
  end;
end;

function TMailServer.DelDirectory(const Source:string): boolean;
var
  fo: TSHFILEOPSTRUCT;
begin
  FillChar(fo, SizeOf(fo), 0);
  with fo do
  begin
    Wnd := 0;
    wFunc := FO_DELETE;
    pFrom := PChar(source+#0);
    pTo := #0#0;
    fFlags := FOF_NOCONFIRMATION+FOF_SILENT;
  end;
  Result := (SHFileOperation(fo) = 0);
end;
{-------------------------------------------------------------------------------
+                    end   系统清理                                            +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}


{-------------------------------------------------------------------------------
+                    Start   读取邮件                                          +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}
procedure TMailServer.Set_MailID(const Value: WideString);
begin
  FMailID:=Value;
end;

procedure TMailServer.Set_UserMail(const Value: WideString);
begin
  FUserMail:=Value;
end;

procedure TMailServer.Set_ReplyState(const Value: WideString);
begin
  FReplyState:=Value;
end;

procedure TMailServer.Set_MailBox(const Value: WideString);
begin
  FMailBox:=Value;
end;

//读取email数据
function TMailServer.Get_MailData: WideString;
var
  MyPath:string;
  MyList:TStringList;
begin
  FComForFileSys.RelyState:=FReplyState;
  FComForFileSys.UserMail:=FUserMail;
  FComForFileSys.MailID:=FMailID;
  FComForFileSys.BoxIndex:=FMailBox;
  MyPath:=FComForFileSys.GetMailPath;
  MyList:=TStringList.Create;
  try
    MyList.LoadFromFile(MyPath);
    result:=MyList.text;
  finally
    MyList.Free;
  end;
end;
{-------------------------------------------------------------------------------
+                    end     读取邮件                                          +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}


{-------------------------------------------------------------------------------
+                    start     读取日志                                        +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}
procedure TMailServer.Set_SetLogTag(const Value: WideString);
begin
  FLogTag:=Value;
end;

function TMailServer.Get_GetLog: WideString;
var
  MyList:TStringList;
  MyPath:string;
begin
  MyList:=TStringList.Create;
  try
    if  FLogTag='1' then
    begin
      MyPath:=FExecPath+'logs\system.log';
      if fileexists(MyPath) then
        MyList.LoadFromFile(MyPath);
    end
    else if FLogTag='2' then
    begin
      MyPath:=FExecPath+'logs\smtp.log';
      if fileexists(MyPath) then
        MyList.LoadFromFile(MyPath);
    end
    else if FLogTag='3' then
    begin
      MyPath:=FExecPath+'logs\pop3.log';
      if fileexists(MyPath) then
        MyList.LoadFromFile(MyPath);
    end
    else if FLogTag='4' then
    begin
      MyPath:=FExecPath+'logs\reply.log';
      if fileexists(MyPath) then
        MyList.LoadFromFile(MyPath);
    end;
    result:=MyList.Text;
  finally
    MyList.Free;
  end;
end;
{-------------------------------------------------------------------------------
+                    end       读取日志                                        +
+                                                                              +
+                                                                              +
--------------------------------------------------------------------------------}



initialization
  TComponentFactory.Create(ComServer, TMailServer,
    Class_MailServer, ciMultiInstance, tmApartment);
end.