Email服务器

开发平台：
Delphi

ufrmNewEmail.pas：源码内容
							unit ufrmNewEmail;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleCtrls, OALib_TLB, dxBar, dxBarExtItems, cxClasses,
  cxGraphics, cxLabel, cxTextEdit, cxControls, cxContainer, cxEdit,
  cxMaskEdit, cxDropDownEdit, ExtCtrls, cxStyles, cxMRUEdit, dxStatusBar,
  ComCtrls, cxLookAndFeels,IdSMTP,uSendMail, DdeMan,uHtmlEdit, 
  SHDocVw, ActnList, uBaseEditorForm;
type
  TfrmNewEMail = class(TBaseEditorForm)
    dxbrmngr1: TdxBarManager;
    btnSend: TdxBarLargeButton;
    btnSave: TdxBarLargeButton;
    dxbrlrgbtn3: TdxBarLargeButton;
    dxbrlrgbtn4: TdxBarLargeButton;
    Panel1: TPanel;
    cbRecver: TcxComboBox;
    cbSender: TcxComboBox;
    edSubject: TcxTextEdit;
    cxLabel1: TcxLabel;
    cxLabel2: TcxLabel;
    cxLabel3: TcxLabel;
    cbAttch: TcxMRUEdit;
    cxLabel4: TcxLabel;
    dlgOpenFile: TOpenDialog;
    dxStatusBar1: TdxStatusBar;
    dxbrbtn1: TdxBarButton;
    dxbrbtn2: TdxBarButton;
    btnSendSave: TdxBarLargeButton;
    dxbrmngr1Bar2: TdxBar;
    dxbrlrgbtn1: TdxBarLargeButton;
    dxbrbtn3: TdxBarButton;
    btn1: TdxBarLargeButton;
    btn2: TdxBarLargeButton;
    ddeConv: TDdeClientConv;
    procedure FormCreate(Sender: TObject);
    procedure cbAttchPropertiesButtonClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
    procedure dxbrlrgbtn3Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnSendSaveClick(Sender: TObject);
    procedure dxbrlrgbtn1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btn1Click(Sender: TObject);
    procedure btn2Click(Sender: TObject);
    procedure ofcOfficeEnter(Sender: TObject);
  private
    { Private declarations }
    FPath:String;
    
    ThreadMailMessage:TThreadMailMessage;
    function CheckInput:Boolean;
  protected
   
    function RTFtoTXT(rtf:string):string;
    procedure SendError(Sender:TObject;ErrMsg:string);
    procedure SendComplete(Sender:TObject);
  public
    { Public declarations }
    FStr:string;
    FSetDoc:Boolean;
    
    function GetRTF: string;
    procedure  SetRtf(S:String);
    procedure RunMacro(Macro:pChar);
  end;
var
  frmNewEMail: TfrmNewEMail;
implementation
uses NativeXml, uCommon, ActiveX, ComObj,WordXP, OleServer, uMyXml,
  UEmailFile, uAttemper,DateUtils,Math;
{$R *.dfm}
procedure TfrmNewEMail.FormCreate(Sender: TObject);
var
  xml:TMyXml;
  Lst:TList;
  I:Integer;
  info:PPopInfo;
  cont:PContactAddress;
begin
  FStr:='';
  FSetDoc:=False;
  xml:=TMyXml.Create(AppPath+'EmailServers.xml');
  try
    if  (xml.Root.FindNode('pop3s')=nil)  then Exit;
    lst:=TList.Create;
    try
      xml.Root.FindNode('pop3s').NodesByName('pop3',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:= TXmlNode(Lst[I]).ReadString('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;
end;
procedure TfrmNewEMail.cbAttchPropertiesButtonClick(Sender: TObject);
var
  I:Integer;
begin
  if dlgOpenFile.Execute then
    for I:=0 to dlgOpenFile.Files.Count-1 do
      cbAttch.Properties.Items.Add(dlgOpenFile.Files.Strings[I]);
  cbAttch.ItemIndex:=0;
end;
procedure TfrmNewEMail.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]));
end;
function GetRTFFormat(DataObject: IDataObject; var RTFFormat: TFormatEtc): Boolean; 
var 
  Formats: IEnumFORMATETC;
  TempFormat: TFormatEtc; 
  pFormatName: PChar; 
  Found: Boolean; 
begin 
  try
    OleCheck(DataObject.EnumFormatEtc(DATADIR_GET, Formats));
    Found := False;
    while (not Found) and (Formats.Next(1, TempFormat, nil) = S_OK) do
    begin
      pFormatName := AllocMem(255);
      GetClipBoardFormatName(TempFormat.cfFormat, pFormatName, 254);
      if (string(pFormatName) = 'Rich Text Format') then
      begin
        RTFFormat := TempFormat;
        //WriteLog(string(pFormatName));
        Found := True;
      end;
      FreeMem(pFormatName);
    end;
    Result := Found;
  except
    Result := False;
  end;
end;
function TfrmNewEMail.GetRTF: string;
var
  DataObject: IDataObject;
  RTFFormat: TFormatEtc;
  ReturnData: TStgMedium;
  Buffer: PChar;
  WordDoc: _Document;
  WordApp: _Application;
begin
  Result := '';
  try
    GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
  except
    ShowMessage('Error: MSWord is not running');
    Exit;
  end;
  if (WordApp <> nil) then
  try
    WordDoc := WordApp.ActiveDocument;
    WordDoc.QueryInterface(IDataObject, DataObject);
    if GetRTFFormat(DataObject, RTFFormat) then
    begin
      OleCheck(DataObject.GetData(RTFFormat, ReturnData));
      //RTF is passed through global memory
      Buffer := GlobalLock(ReturnData.hglobal);
      //Buffer is a pointer to the RTF text
      Result := StrPas(Buffer);
      GlobalUnlock(ReturnData.hglobal);
      ReleaseStgMedium(ReturnData);
    end;
  except
    // Error occured...
  end;
end;
procedure TfrmNewEMail.SetRtf(S: String);
var 
  DataObject: IDataObject;
  RTFFormat: TFormatEtc;
  ReturnData: TStgMedium;
  WordDoc: _Document;
  WordApp: _Application;
begin
  try
    GetActiveOleObject('Word.Application').QueryInterface(_Application, WordApp);
  except
    ShowMessage('Error: MSWord is not running');
    Exit;
  end;
  if (WordApp <> nil) then
  try
    WordDoc := WordApp.ActiveDocument; 
    WordDoc.QueryInterface(IDataObject, DataObject);
    if GetRTFFormat(DataObject, RTFFormat) then
    begin
      ReturnData.tymed:=TYMED_HGLOBAL;
      ReturnData.unkForRelease:=nil;
      ReturnData.hGlobal:=GlobalAlloc(GMEM_MOVEABLE or GMEM_ZEROINIT or GMEM_DDESHARE,Length(S));
      CopyMemory(Ptr(ReturnData.hGlobal),@S[1],Length(S));
      OleCheck(DataObject.SetData(RTFFormat,ReturnData,LongBool(True)));
      //ReleaseStgMedium(ReturnData);
    end;
  except
    // Error occured...
  end;
end;
function TfrmNewEMail.RTFtoTXT(rtf: string): string;
var 
  ss: TStringstream;
  RichEdit: TRichEdit;
begin
  ss := TStringStream.Create(rtf);
  RichEdit:=TRichEdit.Create(self);
  RichEdit.Parent:=Self;
  RichEdit.Visible:=false;
  try
    ss.Position := 0;
    RichEdit.Lines.LoadFromStream(ss); // load rtf into richedit1
    Result:= RichEdit.Lines.Text;
  finally
    RichEdit.Free;
    ss.Free
  end;
end;
procedure TfrmNewEMail.btnSaveClick(Sender: TObject);
var
  EmailFile:TEmailFile;
  MyXml:TMyXml;
begin
  if not CheckInput then Exit;
  
  FPath:=AppPath+'NoSent'+GenalFileName+'.ema';
  EmailFile:=TEmailFile.Create(FPath);
  try
    EmailFile.Sender:=trim(cbSender.Text);
    EmailFile.Recver:=trim(cbRecver.Text) ;
    EmailFile.Subject:=Trim(edSubject.Text);
    EmailFile.Date:=DateTimeToStr(Now) ;
    EmailFile.Content:=trim(RTFtoTXT(GetRTF));
    EmailFile.Size:=IntToStr(Length(EmailFile.Content));
    EmailFile.Attchs:=cbAttch.Properties.Items;
    EmailFile.SaveEmail;
  finally
    EmailFile.Free;
  end;
  MyXml:=TMyXml.create(AppPath+'EmailServers.xml');
  try
    MyXml.SaveNewEmail(trim(cbSender.Text),FPath);
  finally
    MyXml.Free;
  end;
end;
function TfrmNewEMail.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(edSubject.Text)='' then
  begin
      ShowMessage('邮件主题不能为空');
      Exit;
  end;
  for I:=0  to cbAttch.Properties.Items.Count-1 do
  begin
    if not FileExists(cbAttch.Properties.Items[I]) then
    begin
      ShowMessage(Format('附件%S不存在',[cbAttch.Properties.Items[I]]));
      Exit;
    end;
  end;
  try
    if Trim(RTFtoTXT(GetRTF))='' then
    begin
      ShowMessage('邮件正文不能为空');
      Exit;
    end;
  except
    Exit;
  end;
  Result:=True;
end;
procedure TfrmNewEMail.btnSendClick(Sender: TObject);
var
  dest:TDestinationPart;
  Orig:TOriginPart;
  f:TStringList;
  I,idx:Integer;
  info:PPopInfo;
 { Head:TEmailRec;  }
  S:String;  
begin
  if not CheckInput then Exit;
  btnSend.Enabled:=False;
  btnSendSave.Enabled:=False;
  dxStatusBar1.Panels[0].Text:='正在发送邮件，请稍候。。。';
  f:=TStringList.Create;
  
  for I:=0 to cbAttch.Properties.Items.Count-1 do
  begin
    //Attch:=Attch+cbAttch.Properties.Items[I]+';';
    f.Add(cbAttch.Properties.Items[I]);
  end;
  S:=trim(RTFtoTXT(GetRTF));
  dest:=TDestinationPart.Create(Trim(cbRecver.Text),Trim(cbRecver.Text),Trim(cbRecver.Text),'',edSubject.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);
  try
    ThreadMailMessage:=TThreadMailMessage.Create(dest,Orig);
    ThreadMailMessage.OnSendComplete:=Self.SendComplete;
    ThreadMailMessage.OnSendError:=Self.SendError;
    ThreadMailMessage.Resume;
  finally
    Orig.Free;
    dest.Free;
    f.Free;
  end;
end;
procedure TfrmNewEMail.SendComplete(Sender: TObject);
begin
  dxStatusBar1.Panels[0].Text:='邮件发送完毕。';
  btnSend.Enabled:=True;
  btnSendSave.Enabled:=True;
end;
procedure TfrmNewEMail.SendError(Sender: TObject; ErrMsg: string);
begin
  ShowMessage('错误:'+ErrMsg);
  btnSend.Enabled:=True;
  btnSendSave.Enabled:=True;
end;
procedure TfrmNewEMail.dxbrlrgbtn3Click(Sender: TObject);
begin
  if ThreadMailMessage<>nil then  TerminateThread(ThreadMailMessage.Handle,0);
  Self.Close;
end;
procedure TfrmNewEMail.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action:=caFree;
end;
procedure TfrmNewEMail.btnSendSaveClick(Sender: TObject);
var
  MyXml:TMyXml;
begin
  btnSaveClick(nil);
  MyXml:=TMyXml.Create(AppPath+'EmailServers.xml');
  try
    MyXml.AddSentEmail(PPopinfo(cbSender.Properties.Items.Objects[cbSender.ItemIndex]).EMailAddr,FPath);
  finally
    MyXml.Free;
  end;
  btnSendClick(nil);
end;
procedure TfrmNewEMail.dxbrlrgbtn1Click(Sender: TObject);
begin
  ofcOffice.Print;
end;
procedure TfrmNewEMail.FormShow(Sender: TObject);
begin
  ofcOffice.CreateNew('Word.Document');
  ofcOffice.ShowToolbars(True);
  while not ofcOffice.IsOpen do Application.ProcessMessages;
  //if FSetDoc then
  //begin
  //  ofcOffice.SetFocus;
  //  RunMacro('[EditPaste]');
  //end;
   //SetRtf(FStr);
end;
procedure TfrmNewEMail.btn1Click(Sender: TObject);
var
  EmailFile:TEmailFile;
  MyXml:TMyXml;
begin
  if not CheckInput then Exit;
  FPath:=AppPath+'NoSent'+GenalFileName+'.ema';
  EmailFile:=TEmailFile.Create(FPath);
  try
    EmailFile.Sender:=trim(cbSender.Text);
    EmailFile.Recver:=trim(cbRecver.Text) ;
    EmailFile.Subject:=Trim(edSubject.Text);
    EmailFile.Content:=trim(RTFtoTXT(GetRTF));
    EmailFile.Size:=IntToStr(Length(EmailFile.Content));
    EmailFile.Date:=DateTimeToStr(Now);
    EmailFile.Attchs:=cbAttch.Properties.Items;
    EmailFile.SaveEmail;
  finally
    EmailFile.Free;
  end;
  MyXml:=TMyXml.create(AppPath+'EmailServers.xml');
  try
    MyXml.SaveAsDraft(trim(cbSender.Text),FPath);
  finally
    MyXml.Free;
  end;
end;
procedure TfrmNewEMail.btn2Click(Sender: TObject);
var
  EmailFile:TEmailFile;
  MyXml:TMyXml;
begin
  if not CheckInput then Exit;
  with TfrmAttemper.Create(nil) do
  try
    if ShowModal=mrOk then
    begin
      FPath:=AppPath+'NoSent'+GenalFileName+'.ema';
      EmailFile:=TEmailFile.Create(FPath);
      try
        EmailFile.Sender:=trim(cbSender.Text);
        EmailFile.Recver:=trim(cbRecver.Text) ;
        EmailFile.Subject:=Trim(edSubject.Text);
        EmailFile.Date:=DateTimeToStr(DateOf(edDate.Date)+TimeOf(edTime.Time));
        EmailFile.Content:=trim(RTFtoTXT(GetRTF));
        EmailFile.Size:=IntToStr(Length(EmailFile.Content) );
        EmailFile.Attchs:=cbAttch.Properties.Items;
        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;
end;
procedure TfrmNewEMail.RunMacro(Macro: pChar);
var
  pMacro:array[0..80] of Char;
begin
  ddeConv.SetLink('Winword','System');{设置连接}
  ddeConv.OpenLink;{按设置打开连接}
  StrPCopy(pMacro,Macro);
  try
  if Not ddeConv.ExecuteMacro(pMacro,false) then{执行宏命令}
    ShowMessage('Unable to Execute Macro');
  except
  end;
  ddeConv.CloseLink;{断开连接}
  {
 [FileNew] …… 创建新文件
　　[FileClose] …… 关闭文件
　　[FileSave] …… 保存文件
　　[FilePrint] …… 打印文件
　　[FileExit] …… 退出Word
　　[File1] …… 打开最近打开的文件，相应还有[File2]、[File3]等等
　　[EditCut] …… 剪切操作 
　　[EditCopy] …… 复制操作
　　[EditPaste] …… 粘贴操作
　　[EditUndo] …… 恢复上一步
　　[EditRedo] …… 重做上一步
　　[EditClear] …… 清除操作
　　[EditSelectAll] …… 全选操作
　　[ViewNormal] …… 正常视图
　　[ViewPage] …… 页面视图
　　[ViewOutLine] …… 大纲视图
　　[InsertBreak] …… 插入分割符
　　[InsertIndex] …… 插入索引
　　[FormatNumber] …… 格式化项目符号和编号
　　[ToolsOptions] …… 工具的选项
　　[TableInsertTable] …… 插入表格
　　[TableInsertRow] …… 插入行
　　[TableDeleteRow] …… 删除行
　　[TableSplit] …… 拆分表格
　　[TableSelectRow] …… 选择行
　　[TableSelectColumn] …… 选择列
　　[TableSelectTable] …… 选择表格
　　[TableSort] …… 排序
　　[WindowNewWindow] …… 新建窗口
　　[Window1] …… 最近打开的窗口，响应还有[Window2]、[Window3]等等
　　[HelpIndex] …… 帮助的索引
　　[HelpAbout] …… 帮助的关于
  }
end;
procedure TfrmNewEMail.ofcOfficeEnter(Sender: TObject);
begin
  if FSetDoc then
  begin
    FSetDoc:=False;
    RunMacro('[ViewOutLine]');
  end;
end;
end.

						