messageform.pas

这是一套全面的网络组件

unit MessageForm;

interface

uses
  Classes, Controls, Forms, StdCtrls, ComCtrls, {MessagePersister,}
  Menus, ImgList, Windows, Dialogs, DHTMLEDLib_TLB, ExtCtrls,
  ToolWin, MSHTML, {Variants, }OleCtrls, clMailMessage;

{$WARNINGS OFF}
  
type
  TfrmMessage = class(TForm)
    edtSubject: TEdit;
    edtFrom: TEdit;
    cmbPriority: TComboBox;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label6: TLabel;
    lvAttach: TListView;
    MessageParser: TclMailMessage;
    mnuAttach: TPopupMenu;
    mnuInsertFileAttachment: TMenuItem;
    mnuSaveFileAttachment: TMenuItem;
    mnuDeleteFileAttachment: TMenuItem;
    MessageImages: TImageList;
    SaveDialog: TSaveDialog;
    OpenDialog: TOpenDialog;
    pHtmlBody: TPanel;
    edtTo: TEdit;
    Label7: TLabel;
    edtCc: TEdit;
    Label8: TLabel;
    edtBcc: TEdit;
    MainMenu: TMainMenu;
    File1: TMenuItem;
    AppendMessage1: TMenuItem;
    N1: TMenuItem;
    Close1: TMenuItem;
    Edit1: TMenuItem;
    Cut1: TMenuItem;
    Copy1: TMenuItem;
    Paste1: TMenuItem;
    Insert1: TMenuItem;
    FileAttachment1: TMenuItem;
    Picture1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure MessageParserGetBodyStream(Sender: TObject;
      ABody: TclMessageBody; const AFileName: String; var AStream: TStream;
      var Handled: Boolean);
    procedure lvAttachContextPopup(Sender: TObject; MousePos: TPoint;
      var Handled: Boolean);
    procedure mnuInsertFileAttachmentClick(Sender: TObject);
    procedure mnuDeleteFileAttachmentClick(Sender: TObject);
    procedure mnuSaveFileAttachmentClick(Sender: TObject);
    procedure AppendMessage1Click(Sender: TObject);
    procedure Picture1Click(Sender: TObject);
    procedure Close1Click(Sender: TObject);
    procedure Cut1Click(Sender: TObject);
    procedure Copy1Click(Sender: TObject);
    procedure Paste1Click(Sender: TObject);
  private
    FReadOnly: Boolean;
    FSelectedAttachName: string;
    FMailMessage: TStrings;
    wbBody: TDHTMLEdit;
    procedure LoadBodies(ABodySrc: TStrings; ABodies: TclMessageBodies);
    procedure LoadAttachment(ABody: TclAttachmentBody);
    procedure LoadMessage(AMessage: TStrings);
    procedure StoreMessage(AMessage: TStrings);
    procedure UpdateControls;
    procedure GetAttachmentList(AList: TStrings);
    procedure GetImageList(AList: TStrings);
    procedure ClearMessageTempDir;
    procedure ShowBody(ABodySrc: TStrings);
    procedure ReplaceImageName(ABodySrc: TStrings; ABodies: TclMessageBodies);
    procedure ExecCommand(cmdID: OleVariant);
  public
    class function GetMessageTempDir: string;
    class function NewMessage(AMessage: TStrings; const AFrom: string): Boolean;
    class function ShowMessage(AMessage: TStrings; aReadOnly: boolean): Boolean;
  end;

implementation

uses
  SysUtils, FileCtrl, Graphics;

{$R *.dfm}

{ TfrmMessage }

class function TfrmMessage.ShowMessage(AMessage: TStrings; aReadOnly: boolean): Boolean;
var
  Dlg: TfrmMessage;
begin
  Dlg := TfrmMessage.Create(nil);
  try
    Dlg.FReadOnly := aReadOnly;
    Dlg.LoadMessage(AMessage);
    Dlg.ShowModal();
    if not Dlg.FReadOnly then
    begin
      Dlg.StoreMessage(AMessage);
    end;
    Result := (Dlg.ModalResult = mrYes);
  finally
    Dlg.Free();
  end;
end;

procedure TfrmMessage.FormCreate(Sender: TObject);
const
  PiorityMap: array[TclMessagePriority] of string = ('Low', 'Normal', 'High');
var
  i: TclMessagePriority;
begin
  wbBody := TDHTMLEdit.Create(nil);
  wbBody.ControlInterface._AddRef();
  wbBody.Parent := pHtmlBody;
  wbBody.Align := alClient;
  for i := Low(TclMessagePriority) to High(TclMessagePriority) do
  begin
    cmbPriority.Items.Add(PiorityMap[i]);
  end;
end;

procedure TfrmMessage.LoadAttachment(ABody: TclAttachmentBody);
var
  Item: TListItem;
begin
  Item := lvAttach.Items.Add();
  Item.Caption := ABody.FileName;
  Item.ImageIndex := 0;
end;

procedure TfrmMessage.GetAttachmentList(AList: TStrings);
var
  i: Integer;
begin
  AList.Clear();
  for i := 0 to lvAttach.Items.Count - 1 do
  begin
    AList.Add(GetMessageTempDir() + lvAttach.Items[i].Caption);
  end;
end;

procedure TfrmMessage.GetImageList(AList: TStrings);
var
  i: Integer;
  item: IHTMLElement;
  s: string;
begin
  AList.Clear();
  for i := 0 to wbBody.DOM.images.length - 1 do
  begin
    if (wbBody.DOM.images.item(i, 0).QueryInterface(IHTMLElement, item) = S_OK) then
    begin
      s := string(item.GetAttribute('src', 2));
      if (ExtractFileName(s) = s) then
      begin
        s := GetMessageTempDir() + ExtractFileName(s);
      end;
      AList.Add(s);
    end;
  end;
end;

procedure TfrmMessage.LoadBodies(ABodySrc: TStrings; ABodies: TclMessageBodies);
var
  i: Integer;
begin
  for i := 0 to ABodies.Count - 1 do
  begin
    if (ABodies[i] is TclMultipartBody) then
    begin
      LoadBodies(ABodySrc, (ABodies[i] as TclMultipartBody).Bodies);
    end else
    if (ABodies[i] is TclTextBody) then
    begin
      ABodySrc.Assign((ABodies[i] as TclTextBody).Strings);
    end else
    if (ABodies[i].ClassType = TclAttachmentBody) then
    begin
      LoadAttachment(ABodies[i] as TclAttachmentBody);
    end;
  end;
end;

procedure TfrmMessage.LoadMessage(AMessage: TStrings);
var
  BodySrc: TStrings;
begin
  FMailMessage := AMessage;
  MessageParser.MessageSource := AMessage;
  edtSubject.Text := MessageParser.Subject;
  edtFrom.Text := MessageParser.From;
  edtTo.Text := EmailListToString(MessageParser.ToList);
  edtCc.Text := EmailListToString(MessageParser.CCList);
  edtBcc.Text := EmailListToString(MessageParser.BCCList);
  cmbPriority.ItemIndex := Integer(MessageParser.Priority);
  lvAttach.Items.Clear();
  BodySrc := TStringList.Create();
  try
    LoadBodies(BodySrc, MessageParser.Bodies);
    ShowBody(BodySrc);
  finally
    BodySrc.Free();
  end;
end;

procedure TfrmMessage.ReplaceImageName(ABodySrc: TStrings; ABodies: TclMessageBodies);
var
  i: Integer;
begin
  for i := 0 to ABodies.Count - 1 do
  begin
    if (ABodies[i] is TclImageBody) then
    begin
      ABodySrc.Text := StringReplace(ABodySrc.Text, 'cid:' + (ABodies[i] as TclImageBody).ContentID,
        (ABodies[i] as TclImageBody).FileName, [rfReplaceAll, rfIgnoreCase]);
    end else
    if (ABodies[i] is TclMultipartBody) then
    begin
      ReplaceImageName(ABodySrc, (ABodies[i] as TclMultipartBody).Bodies);
    end;
  end;
end;

procedure TfrmMessage.ShowBody(ABodySrc: TStrings);
var
  PathIn, UserPrompt: OleVariant;
begin
  ReplaceImageName(ABodySrc, MessageParser.Bodies);
  ABodySrc.SaveToFile(GetMessageTempDir() + 'htmlbody.htm');
  PathIn := GetMessageTempDir() + 'htmlbody.htm';
  UserPrompt := False;
  wbBody.BrowseMode := FReadOnly;
  wbBody.LoadDocument(PathIn, UserPrompt);
end;

procedure TfrmMessage.StoreMessage(AMessage: TStrings);
var
  BodySrc, Images, Attach: TStrings;
  PathIn, UserPrompt: OleVariant;
begin
  if FReadOnly then Exit;
  BodySrc := TStringList.Create();
  Images := TStringList.Create();
  Attach := TStringList.Create();
  try
    GetImageList(Images);
    GetAttachmentList(Attach);
    PathIn := GetMessageTempDir() + 'htmlbody.htm';
    UserPrompt := False;
    wbBody.SaveDocument(PathIn, UserPrompt);
    while wbBody.Busy and not (csDestroying in ComponentState) do
      Application.ProcessMessages();
    BodySrc.LoadFromFile(GetMessageTempDir() + 'htmlbody.htm');
    MessageParser.BuildMessage(string(wbBody.DOM.body.innerText), BodySrc.Text, Images, Attach);
  finally
    Attach.Free();
    Images.Free();
    BodySrc.Free();
  end;
  MessageParser.Subject := edtSubject.Text;
  MessageParser.From := edtFrom.Text;
  StringToEmailList(edtTo.Text, MessageParser.ToList);
  StringToEmailList(edtCc.Text, MessageParser.CCList);
  StringToEmailList(edtBcc.Text, MessageParser.BCCList);
  MessageParser.Priority := TclMessagePriority(cmbPriority.ItemIndex);
  AMessage.Assign(MessageParser.MessageSource);
end;

procedure TfrmMessage.UpdateControls;
const
  FormCaption: array[Boolean] of string = ('Mail Message Editor', 'Mail Message Viewer');
  ColorMask: array[Boolean] of TColor = (clWindow, clBtnFace);
begin
  Caption := FormCaption[FReadOnly];
  edtFrom.ReadOnly := FReadOnly;
  edtSubject.ReadOnly := FReadOnly;
  edtTo.ReadOnly := FReadOnly;
  edtCc.ReadOnly := FReadOnly;
  edtBcc.ReadOnly := FReadOnly;
  cmbPriority.Enabled := not FReadOnly;
  edtSubject.Color := ColorMask[FReadOnly];
  edtFrom.Color := ColorMask[FReadOnly];
  edtTo.Color := ColorMask[FReadOnly];
  edtCc.Color := ColorMask[FReadOnly];
  edtBcc.Color := ColorMask[FReadOnly];
  AppendMessage1.Enabled := not FReadOnly;
  Cut1.Enabled := not FReadOnly;
  Paste1.Enabled := not FReadOnly;
  FileAttachment1.Enabled := not FReadOnly;
  Picture1.Enabled := not FReadOnly;
end;

procedure TfrmMessage.FormShow(Sender: TObject);
begin
  UpdateControls();
  FSelectedAttachName := '';
end;

class function TfrmMessage.NewMessage(AMessage: TStrings; const AFrom: string): Boolean;
var
  Dlg: TfrmMessage;
begin
  Dlg := TfrmMessage.Create(nil);
  try
    Dlg.FReadOnly := False;
    Dlg.LoadMessage(AMessage);
    Dlg.edtFrom.Text := AFrom;
    Dlg.ShowModal();
    if not Dlg.FReadOnly then
    begin
      Dlg.StoreMessage(AMessage);
    end;
//    AMessage.MarkedAsRead := True;
    Result := (Dlg.ModalResult = mrYes);
  finally
    Dlg.Free();
  end;
end;

procedure TfrmMessage.MessageParserGetBodyStream(Sender: TObject;
  ABody: TclMessageBody; const AFileName: String; var AStream: TStream;
  var Handled: Boolean);
begin
  if FReadOnly then
  begin
    if (FSelectedAttachName = AFileName) then
    begin
      SaveDialog.FileName := AFileName;
      if SaveDialog.Execute() then
      begin
        AStream := TFileStream.Create(SaveDialog.FileName, fmCreate);
      end;
      FSelectedAttachName := '';
    end else
    if (ABody is TclImageBody) then
    begin
      AStream := TFileStream.Create(GetMessageTempDir() + AFileName, fmCreate);
    end;
  end else
  begin
    AStream := TFileStream.Create(GetMessageTempDir() + AFileName, fmCreate);
  end;
  Handled := True;
end;

procedure TfrmMessage.lvAttachContextPopup(Sender: TObject;
  MousePos: TPoint; var Handled: Boolean);
begin
  mnuInsertFileAttachment.Enabled := not FReadOnly;
  mnuDeleteFileAttachment.Enabled := not FReadOnly and (lvAttach.Selected <> nil);
  mnuSaveFileAttachment.Enabled := FReadOnly and (lvAttach.Selected <> nil);
end;

procedure TfrmMessage.ClearMessageTempDir;
var
  Res: Integer;
  sr: TSearchRec;
  Attr: Integer;
  ADir: String;
  FileAttr: DWORD;
begin
  ADir := GetMessageTempDir();
  if not DirectoryExists(ADir) then Exit;
  Attr := faAnyFile and (not faDirectory);
  Res := SysUtils.FindFirst(ADir + '\*.*', Attr, sr);
  while (Res = 0) do
  begin
    FileAttr := GetFileAttributes(PChar(ADir + '\' + sr.FindData.cFileName));
    if ((FileAttr and FILE_ATTRIBUTE_READONLY) > 0) then
    begin
      SetFileAttributes(PChar(ADir + '\' + sr.FindData.cFileName), FileAttr xor FILE_ATTRIBUTE_READONLY);
    end;
    SysUtils.DeleteFile(ADir + '\' + sr.FindData.cFileName);
    Res := SysUtils.FindNext(sr);
  end;
  SysUtils.FindClose(sr);
end;

class function TfrmMessage.GetMessageTempDir: string;
var
  Buffer: array[0..MAX_PATH - 1] of Char;
begin
  SetString(Result, Buffer, GetTempPath(SizeOf(Buffer), Buffer));
  if (Result <> '') and (Result[Length(Result)] <> '\') then
  begin
    Result := Result + '\';
  end;
  Result := Result + 'CleverMailClient\';
  ForceDirectories(Result);
end;

procedure TfrmMessage.mnuInsertFileAttachmentClick(Sender: TObject);
var
  Item: TListItem;
  NewName: string;
begin
  if OpenDialog.Execute() then
  begin
    NewName := GetMessageTempDir() + ExtractFileName(OpenDialog.FileName);
    CopyFile(PChar(OpenDialog.FileName), PChar(NewName), False);
    Item := lvAttach.Items.Add();
    Item.Caption := ExtractFileName(OpenDialog.FileName);
    Item.ImageIndex := 0;
  end;
end;

procedure TfrmMessage.mnuDeleteFileAttachmentClick(Sender: TObject);
begin
  Assert(lvAttach.Selected <> nil);
  DeleteFile(GetMessageTempDir() + lvAttach.Selected.Caption);
  lvAttach.Selected.Delete();
end;

procedure TfrmMessage.mnuSaveFileAttachmentClick(Sender: TObject);
begin
  Assert(lvAttach.Selected <> nil);
  FSelectedAttachName := lvAttach.Selected.Caption;
  try
    MessageParser.MessageSource := FMailMessage;
  finally
    FSelectedAttachName := '';
  end;
end;

procedure TfrmMessage.FormDestroy(Sender: TObject);
begin
  ClearMessageTempDir();
  wbBody.Free();
end;

procedure TfrmMessage.AppendMessage1Click(Sender: TObject);
begin
  ModalResult := mrYes;
end;

procedure TfrmMessage.Close1Click(Sender: TObject);
begin
  ModalResult := mrOK;
end;

procedure TfrmMessage.ExecCommand(cmdID: OleVariant);
var
  pVar: OleVariant;
begin
  if not wbBody.Busy then
  begin
    try
      if ((wbBody.QueryStatus(CmdID) and DECMDF_ENABLED) = DECMDF_ENABLED) then
      begin
        pVar := 0;
        wbBody.ExecCommand(cmdID, 0, pVar);
      end;
    except
    end;
  end;
end;

procedure TfrmMessage.Cut1Click(Sender: TObject);
begin
  ExecCommand(DECMD_CUT);
end;

procedure TfrmMessage.Copy1Click(Sender: TObject);
begin
  ExecCommand(DECMD_COPY);
end;

procedure TfrmMessage.Paste1Click(Sender: TObject);
begin
  ExecCommand(DECMD_PASTE);
end;

procedure TfrmMessage.Picture1Click(Sender: TObject);
begin
  ExecCommand(DECMD_IMAGE);
end;

end.