Email服务器

开发平台：
Delphi

ufrmWriteEmail.pas：源码内容
							unit ufrmWriteEmail;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, uBaseEditorForm, ActnList, uHtmlEdit, dxBar, ImgList,
  dxBarExtItems, cxClasses, OleCtrls, SHDocVw, ExtCtrls, cxGraphics,
  cxMRUEdit, cxLabel, cxTextEdit, cxControls, cxContainer, cxEdit,
  cxMaskEdit, cxDropDownEdit,uSendMail, dxStatusBar,idsmtp,uSingnalMgr,
  cxCheckListBox, cxButtonEdit, Menus, cxLookAndFeelPainters, StdCtrls,
  cxButtons, dxSkinsCore, dxSkinsdxBarPainter, dxSkinBlack, dxSkinBlue,
  dxSkinCaramel, dxSkinCoffee, {dxSkinDarkRoom,} dxSkinDarkSide, {dxSkinFoggy,}
  dxSkinGlassOceans, dxSkiniMaginary, dxSkinLilian, dxSkinLiquidSky,
  dxSkinLondonLiquidSky, dxSkinMcSkin, dxSkinMoneyTwins,
  dxSkinOffice2007Black, dxSkinOffice2007Blue, dxSkinOffice2007Green,
  dxSkinOffice2007Pink, dxSkinOffice2007Silver, dxSkinPumpkin, {dxSkinSeven,}
  {dxSkinSharp,} dxSkinSilver, {dxSkinSpringTime,} dxSkinStardust,
  dxSkinSummer2008, dxSkinsDefaultPainters, dxSkinValentine,
  dxSkinXmas2008Blue, dxSkinsdxStatusBarPainter;
type
  TfrmWriteEmail = class(TBaseEditorForm)
    btnSend: TdxBarLargeButton;
    btnSave: TdxBarLargeButton;
    btn3: TdxBarLargeButton;
    btn4: TdxBarLargeButton;
    btnSendSave: TdxBarLargeButton;
    btn7: TdxBarLargeButton;
    btn8: TdxBarLargeButton;
    pnl1: TPanel;
    cbRecver: TcxComboBox;
    cbSender: TcxComboBox;
    edtSubject: TcxTextEdit;
    lbl2: TcxLabel;
    lbl3: TcxLabel;
    lbl4: TcxLabel;
    lbl5: TcxLabel;
    dxStatusBar1: TdxStatusBar;
    btn6: TdxBarLargeButton;
    btn1: TdxBarLargeButton;
    pm3: TdxBarPopupMenu;
    btn2: TdxBarButton;
    btn5: TdxBarButton;
    dxbrgrp1: TdxBarGroup;
    dxbrgrp2: TdxBarGroup;
    dxbrgrp3: TdxBarGroup;
    dxbrgrp4: TdxBarGroup;
    dxbrgrp5: TdxBarGroup;
    dxbrgrp6: TdxBarGroup;
    dxbrgrp7: TdxBarGroup;
    lstAttch: TcxCheckListBox;
    btnAddAttvh: TcxButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
    procedure btn8Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnSendSaveClick(Sender: TObject);
    procedure btn3Click(Sender: TObject);
    procedure btn4Click(Sender: TObject);
    procedure cbAttchPropertiesButtonClick(Sender: TObject);
    procedure btn6Click(Sender: TObject);
    procedure btn7Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btn1Click(Sender: TObject);
    procedure cbAttchKeyPress(Sender: TObject; var Key: Char);
    procedure btnAddAttvhClick(Sender: TObject);
  private
    { Private declarations }
    FPath:String;
    FSingnalMgr:TAppSingnalMgr;
    ThreadMailMessage:TThreadMailMessage;
    FCheckPass:Boolean;
    function CheckInput:Boolean;
    procedure MyBtnClick(Sender:Tobject);
  protected
    procedure SendError(Sender:TObject;ErrMsg:string);
    procedure SendComplete(Sender:TObject);
    function GetEmailAsHtml:string;
    function GetEmailAsText:string;
    procedure LoadSingnalMenu;
  public
    { Public declarations }
    FStr:string;
    FSetDoc:Boolean;
    procedure AddAttch(List:TStrings);
  end;
{
调用时，不要删除cbSender combox中的项！！！ 因为这没有必要。
}
var
  frmWriteEmail: TfrmWriteEmail;
implementation
{$R *.dfm}
uses uMyxml, uCommon, NativeXml, UEmailFile, uAttemper,dateutils, ufrmMain;
procedure TfrmWriteEmail.FormCreate(Sender: TObject);
var
  xml:TMyXml;
  Lst:TList;
  I:Integer;
  info:PPopInfo;
  cont:PContactAddress;
begin
  pnl1.Height:=130;
  FStr:='';
  FSetDoc:=False;
  xml:=TAPPXml.Create;
  try
    if  (xml.Pop3sNode=nil)  then Exit;
    lst:=TList.Create;
    try
      xml.Pop3Nodes(lst);
      for I:=0 to Lst.Count-1 do
      begin
        New(info);
        info.EMailAddr:=TXmlNode(Lst[I]).ReadString('emailaddr');
        info.pwd:=TXmlNode(Lst[I]).ReadString('pwd');
        info.saveto:= xml.Pop3sNode.AttributeByName['emailsaveto'];
        info.pop3Server:=  TXmlNode(Lst[I]).ReadString('pop3server');
        cbSender.Properties.Items.AddObject(TXmlNode(Lst[I]).ReadString('emailaddr'),TObject(info));
      end;
      cbSender.ItemIndex:=0;
      
      if  xml.Root.FindNode('emails')=nil then Exit; 
      Lst.Clear;
      xml.Root.FindNode('emails').NodesByName('email',lst); //从地址薄中读数据
      for I:=0 to Lst.Count-1 do
      begin
        New(cont);
        cont.Email:=TXmlNode(Lst[I]).ReadString('addr');
        cont.displayname:=TXmlNode(Lst[I]).ReadString('displayname');
        cbRecver.Properties.Items.AddObject(TXmlNode(Lst[I]).ReadString('addr'),TObject(cont));
      end;
      cbRecver.ItemIndex:=0;
    finally
      Lst.Free;
    end;
  finally
    xml.Free;
  end;
  FSingnalMgr:=TAppSingnalMgr.Create;
  FSingnalMgr.LoadFromFile;
  LoadSingnalMenu;
end;
procedure TfrmWriteEmail.cbAttchPropertiesButtonClick(Sender: TObject);
{var
  I:Integer;    }
begin
  {dlgOpen.Filter:='所有文件|*.*';
  if dlgOpen.Execute then
    for I:=0 to dlgOpen.Files.Count-1 do
      cbAttch.Properties.Items.Add(dlgOpen.Files.Strings[I]);
  cbAttch.ItemIndex:=0; }
end;
procedure TfrmWriteEmail.FormDestroy(Sender: TObject);
var
  I:Integer;
begin
  for I:=0 to cbRecver.Properties.Items.Count-1 do
    Dispose(PContactAddress(cbRecver.Properties.Items.Objects[I]));
  for I:=0 to cbSender.Properties.Items.Count-1 do
    Dispose(PPopInfo(cbSender.Properties.Items.Objects[I]));
  FSingnalMgr.Free;
  inherited ;
end;
procedure TfrmWriteEmail.btnSaveClick(Sender: TObject);
var
  EmailFile:TEmailFile;
  MyXml:TMyXml;
  L:TStrings;
  I:integer;
begin
  FCheckPass:=CheckInput;
  if not FCheckPass then Exit;
  FPath:=frmMain.FEmailSaveTo+GenalFileName+'.ema';
  EmailFile:=TEmailFile.Create(FPath);
  try
    EmailFile.Sender:=trim(cbSender.Text);
    EmailFile.Recver:=trim(cbRecver.Text) ;
    EmailFile.Subject:=Trim(edtSubject.Text);
    EmailFile.Date:=DateTimeToStr(Now) ;
    EmailFile.Content:=trim(getEmailAsHtml);
    EmailFile.Size:=IntToStr(Length(EmailFile.Content));
    L:=TStringList.Create;
    try
      for I:=0 to lstAttch.Items.Count-1 do
        if lstAttch.Items[I].Checked then L.Add(lstAttch.Items[I].Text);
      EmailFile.Attchs:=L; //cbAttch.Properties.Items;
    finally
      L.Free;
    end;
    EmailFile.SaveEmail;
  finally
    EmailFile.Free;
  end;
  MyXml:=TAppXml.Create;
  try
    MyXml.SaveNewEmail(trim(cbSender.Text),FPath);
  finally
    MyXml.Free;
  end;
  close;
end;
function TfrmWriteEmail.CheckInput: Boolean;
var
  I:Integer;
begin
  Result:=False;
  if not TEMailAddress.IsEmail(trim(cbRecver.Text)) then
  begin
    ShowMessage('收件人地址不正确');
    Exit;
  end;
  if not TEMailAddress.IsEmail(cbSender.Text) then
  begin
      ShowMessage('发件人地址不正确');
      Exit;
  end;
  if Trim(edtSubject.Text)='' then
  begin
      ShowMessage('邮件主题不能为空');
      Exit;
  end;
  for I:=0  to lstAttch.Items.Count-1 do
  begin
    if not FileExists(lstAttch.Items[I].Text) then
    begin
      ShowMessage(Format('附件%S不存在',[lstAttch.Items[I].Text]));
      Exit;
    end;
  end;
  try
    if Trim(GetEmailAsHtml)='' then
    begin
      ShowMessage('邮件正文不能为空');
      Exit;
    end;
  except
    Exit;
  end;
  Result:=True;
end;
procedure TfrmWriteEmail.SendComplete(Sender: TObject);
begin
  dxStatusBar1.Panels[0].Text:='邮件发送完毕';
  btnSend.Enabled:=True;
  btnSendSave.Enabled:=True;
end;
procedure TfrmWriteEmail.SendError(Sender: TObject; ErrMsg: string);
begin
  ShowMessage('错误:'+ErrMsg);
  btnSend.Enabled:=True;
  btnSendSave.Enabled:=True;
end;
procedure TfrmWriteEmail.btnSendClick(Sender: TObject);
var
  dest:TDestinationPart;
  Orig:TOriginPart;
  f:TStringList;
  I,idx:Integer;
  info:PPopInfo;
  Email:TEmailInfo;
  S:String;
  xml:TAppXml;
begin
  btnSaveClick(nil);
  if not FCheckPass then Exit;
  
  f:=TStringList.Create;
  for I:=0 to lstAttch.Items.Count-1 do
    if lstAttch.Items[I].Checked then f.Add(lstAttch.Items[I].Text);
  S:=trim(GetEmailAsHtml);
  dest:=TDestinationPart.Create(Trim(cbRecver.Text),Trim(cbRecver.Text),Trim(cbRecver.Text),'',edtSubject.Text,S,f);
  idx:=cbSender.ItemIndex;
  info:=PPopinfo(cbSender.Properties.Items.Objects[idx]);
  Orig:=TOriginPart.Create(atDefault,Trim(info.EMailAddr),Trim(info.EMailAddr),Trim(info.pwd),TEMailAddress.SMTPEmailSever(Trim(info.EMailAddr)),25);
  Email:=TEmailInfo.create;
  try
    Email.Recv:=Dest;
    Email.Send:=Orig;
    Email.id:=FPath;
    frmMain.EmailSenderMgr.Push(Email);
    xml:=TAppXml.Create;
    try
      xml.AddSendingEmail(info.EMailAddr,Fpath);
    finally
      xml.Free;
    end;
    frmMain.EmailSenderMgr.Send;
  finally
    Email.Free;
    Orig.Free;
    dest.Free;
    f.Free;
  end;
  close;
end;
procedure TfrmWriteEmail.btn8Click(Sender: TObject);
begin
  if ThreadMailMessage<>nil then  TerminateThread(ThreadMailMessage.Handle,0);
  Self.Close;
end;
procedure TfrmWriteEmail.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action:=caFree;
end;
procedure TfrmWriteEmail.btnSendSaveClick(Sender: TObject);
var
  MyXml:TAppXml;
begin
  if not CheckInput then exit;
  try
    btnSendClick(nil);
  finally
    MyXml:=TAppXml.Create;
    try
      MyXml.AddSentEmail(PPopinfo(cbSender.Properties.Items.Objects[cbSender.ItemIndex]).EMailAddr,FPath);
    finally
      MyXml.Free;
    end;
  end;
  close;
end;
procedure TfrmWriteEmail.btn3Click(Sender: TObject);
var
  EmailFile:TEmailFile;
  MyXml:TMyXml;
  L:TStrings;
  I:integer;
begin
  if not CheckInput then Exit;
  FPath:=FrmMain.FEmailSaveTo;
  EmailFile:=TEmailFile.Create(FPath);
  try
    EmailFile.Sender:=trim(cbSender.Text);
    EmailFile.Recver:=trim(cbRecver.Text) ;
    EmailFile.Subject:=Trim(edtSubject.Text);
    EmailFile.Content:=trim(GetEmailAsHtml);
    EmailFile.Size:=IntToStr(Length(EmailFile.Content));
    EmailFile.Date:=DateTimeToStr(Now);
    L:=TStringList.Create;
    try
      for I:=0 to lstAttch.Count-1 do
        if lstAttch.Items[I].Checked then L.Add(lstAttch.Items[I].Text);
      EmailFile.Attchs:=L; //cbAttch.Properties.Items;
    finally
      L.Free;
    end;
    EmailFile.SaveEmail;
  finally
    EmailFile.Free;
  end;
  MyXml:=TMyXml.create(AppPath+'EmailServers.xml');
  try
    MyXml.SaveAsDraft(trim(cbSender.Text),FPath);
  finally
    MyXml.Free;
  end;
  close;
end;
procedure TfrmWriteEmail.btn4Click(Sender: TObject);
var
  EmailFile:TEmailFile;
  MyXml:TMyXml;
  L:TStrings;
  I:Integer;
begin
  if not CheckInput then Exit;
  with TfrmAttemper.Create(nil) do
  try
    if ShowModal=mrOk then
    begin
      FPath:=frmMain.FEmailSaveTo;
      EmailFile:=TEmailFile.Create(FPath);
      try
        EmailFile.Sender:=trim(cbSender.Text);
        EmailFile.Recver:=trim(cbRecver.Text) ;
        EmailFile.Subject:=Trim(edtSubject.Text);
        EmailFile.Date:=FormatDateTime('YYYY-MM-DD hh:nn:ss', Trunc(Date) + Frac(Time));
        EmailFile.Content:=trim(GetEmailAsHtml);
        EmailFile.Size:=IntToStr(Length(EmailFile.Content) );
        L:=TStringList.Create;
        try
          for I:=0 to lstAttch.Items.Count-1 do
            if lstAttch.Items[I].Checked then L.Add(lstAttch.Items[I].Text);
          EmailFile.Attchs:=L ;//cbAttch.Properties.Items;
        finally
          L.Free;
        end;
        EmailFile.SaveEmail;
      finally
        EmailFile.Free;
      end;
      MyXml:=TMyXml.create(AppPath+'EmailServers.xml');
      try
        MyXml.SaveAsAttampter(trim(cbSender.Text),FPath,DateOf(edDate.Date)+TimeOf(edTime.Time));
      finally
        MyXml.Free;
      end;
    end;
  finally
    Free;
  end;
  close;
end;
function TfrmWriteEmail.GetEmailAsHtml: string;
begin
  result:=HtmlEdit.HTML;
end;
function TfrmWriteEmail.GetEmailAsText: string;
begin
  result:=HtmlEdit.Text;
end;
procedure TfrmWriteEmail.btn6Click(Sender: TObject);
begin
  HtmlEdit.PrintPageSetup;
  HtmlEdit.Print;
end;
procedure TfrmWriteEmail.btn7Click(Sender: TObject);
begin
  HtmlEdit.PrintPageSetup;
  HtmlEdit.PrintPreview;
end;
procedure TfrmWriteEmail.FormShow(Sender: TObject);
begin
  inherited;
  if (Fstr<>'')  then
  begin
    HtmlEdit.Insert(FStr);
  end;
end;
procedure TfrmWriteEmail.LoadSingnalMenu;
var
  btn:TdxBarButton;
  I:integer;
  pData:PSingnalData;
begin
  I:=0;
  FSingnalMgr.Iterator.First;
  while FSingnalMgr.Iterator.HasNext do
  begin
    btn:= pm3.BarManager.AddButton;
    btn.ButtonStyle:=bsChecked;
    pData:=PSingnalData(FSingnalMgr.Iterator.Next);
    btn.Caption:=pData.Caption;
    btn.Tag:=I;
    btn.Down:=pData.Default;
    btn.AllowAllUp:=False;
    btn.Category:=5;
    dxbrmngr1.Groups[5].Add(btn);
    btn.GroupIndex:=5;
    pm3.ItemLinks.Add.Item:=btn;
    btn.OnClick:=MyBtnClick;
    btn.ImageIndex:=I;
    inc(I);
  end;   
end;
procedure TfrmWriteEmail.MyBtnClick(Sender: Tobject);
begin
  HtmlEdit.Insert(StrPas(FSingnalMgr.Get(TdxBarButton(Sender).Tag).Text));
end;
procedure TfrmWriteEmail.btn1Click(Sender: TObject);
var
  I:integer;
begin
  for I:=0 to dxbrmngr1.Groups[5].Count-1 do
    if TdxBarButton(dxbrmngr1.Groups[5].Items[I]).Down then
      HtmlEdit.Insert(StrPas(FSingnalMgr.Get(TdxBarButton(dxbrmngr1.Groups[5].Items[I]).Tag).Text));
end;
procedure TfrmWriteEmail.cbAttchKeyPress(Sender: TObject; var Key: Char);
{var
  idx:Integer;}
begin
//  if cbAttch.Text='' then Exit;
//  if byte(Key) in [8,12,46] then {推格键，vbClear,vk_Delete}
//  begin
//    idx:=cbAttch.Properties.Items.IndexOf(cbAttch.Text);
//    cbAttch.Properties.Items.Delete(idx);
//    cbAttch.Text:='';
//  end;
end;
procedure TfrmWriteEmail.btnAddAttvhClick(Sender: TObject);
var
  I:integer;
begin
  dlgOpen.Filter:='所有文件|*.*';
  if dlgOpen.Execute then
  begin
    for I:=0 to dlgOpen.Files.Count-1 do
    begin
      with lstAttch.Items.Add  do
      begin
        Text:=dlgOpen.Files[I];
        Checked:=True;
      end;
    end;
    pnl1.Height:=234;
  end;
end;
procedure TfrmWriteEmail.AddAttch(List: TStrings);
var
  I:Integer;
begin
  for I:=0 to List.Count-1 do
    with lstAttch.Items.Add  do
    begin
      Text:=List[I];
      Checked:=True;
    end;
end;
end.

						