Delphi控件源码

开发平台：
Delphi

HistoryFrm.pas：源码内容
							unit HistoryFrm;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ToolWin, ComCtrls, OleCtrls, SHDocVw,MSHTML,ActiveX,WNDES,ChatingFrm,
  ExtCtrls, ImgList,Global,StrUtils;
type
  THistoryForm = class(TForm)
    Panel1: TPanel;
    WebBrowser1: TWebBrowser;
    ImageList1: TImageList;
    CoolBar1: TCoolBar;
    ToolBar1: TToolBar;
    TBCopy: TToolButton;
    TBFind: TToolButton;
    TBPrint: TToolButton;
    TBDel: TToolButton;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure TBFindClick(Sender: TObject);
    procedure TBPrintClick(Sender: TObject);
    procedure TBDelClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure TBCopyClick(Sender: TObject);
  private
  public
    ID:Integer;
    Name:String;
  end;
  
var
  HistoryForm: THistoryForm;
  
implementation
uses
  RealMessengerUnit;
{$R *.dfm}
{窗口关闭时，释放窗口}
procedure THistoryForm.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action:=caFree;
  HistoryForm:=nil;
end;
{查找}
procedure THistoryForm.TBFindClick(Sender: TObject);
const
CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
var
  CmdTarget : IOleCommandTarget;
  vaIn, vaOut: OleVariant;
  PtrGUID: PGUID;
begin
  New(PtrGUID);
  PtrGUID^ := CGID_WebBrowser;
  if WebBrowser1.Document <> nil then
   try
     WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
     if CmdTarget <> nil then
      try
        CmdTarget.Exec( PtrGUID, 1, 0, vaIn, vaOut);
       finally
         CmdTarget._Release;
       end;
   except
    // Nothing
    end;
  Dispose(PtrGUID);
end;
{打印}
procedure THistoryForm.TBPrintClick(Sender: TObject);
begin
  try
    WebBrowser1.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER);
  except
  end;
end;
{删除}
procedure THistoryForm.TBDelClick(Sender: TObject);
begin
  if MessageBox(Handle,PChar('确定要删除与 '+Name+' 的对话历史记录吗？'),'确认删除',MB_ICONQUESTION or MB_OKCANCEL	)=ID_OK then
  try
    DeleteFile(HistoryPath+''+IntToStr(Me.ID)+''+IntToStr(ID)+'.xml');
    Hide;
    MessageBox(Handle,'历史记录已被删除！','提示',MB_ICONINFORMATION);
    Close;
  except
    MessageBox(Handle,'未能删除历史记录！','错误',MB_ICONERROR);
  end;
end;
procedure THistoryForm.FormShow(Sender: TObject);
var
  HistoryFile,MyHistoryPath:String;
  FileStream:TFileStream;
  DoC: IHTMLDocument2;
  CBMessage:TCBMessage;
  Employee:PEmployee;
  iLoop:Integer;
begin
  MyHistoryPath:=HistoryPath+''+IntToStr(Me.ID);
  if not DirectoryExists(MyHistoryPath) then CreateDir(MyHistoryPath);
  HistoryFile:=MyHistoryPath+''+IntToStr(ID)+'.xml';
  if not FileExists(HistoryFile) then
  begin
    MessageBox(Handle,PChar('没有找到任何与 '+Name+' 有关的对话历史记录！'),'提示',MB_ICONINFORMATION);
    Width:=0;
    Height:=0;
    Left:=-100;
    Top:=-100;
    Close;
    Exit;
  end;
  Caption:=Name+' 的历史记录';
  WebBrowser1.Navigate('file://'+AnsiReplaceStr(AnsiReplaceStr(HistoryFile,'\',''),'','/'));
end;
procedure THistoryForm.TBCopyClick(Sender: TObject);
begin
  try
    WebBrowser1.ExecWB(OLECMDID_COPY, OLECMDEXECOPT_PROMPTUSER);
  except
  end;
end;
end.

						