PageControl封装WebBrowser及游览器

unit uTWebBrowse;

interface
uses      Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
   Dialogs,ComCtrls, OleCtrls, SHDocVw,MSHTML,StdCtrls,ActiveX,
  ExtCtrls;

const
  HTMLID_FIND       = 1;
  HTMLID_VIEWSOURCE = 2;
  HTMLID_OPTIONS    = 3;

type
{-------------------------------------------------------------
说明：浏览器页面类 (包含单元SHDocVw)
功能: 实现多页浏览像MYIE一样
作者：lihuizhan
--------------------------------------------------------------}
    TProgressEvent =procedure(Sender: TObject; Progress,
            ProgressMax: Integer) of object;
    TWebBrowserCommandStateChangeEvent=procedure(Sender: TObject;
            Command: Integer; Enable: WordBool) of object;

    TNewIEPage=class(Tobject)
    private
        FpageControl    : TPageControl;
        FplClient          : TPanel;
        FsheetItem      : TTabSheet;
        FWebBrowser     : TWebBrowser;
        FIsActive       : boolean ;//暂时没有用到
        FCaption        :String;//标题
        FUrl            :string;//URL
        FCount          :integer;
        FHistoryList     :TstringList;//历史记录
        FHistoryIndex    :integer;// 当前URL索引
        FGoBackState    :boolean;//向后按钮状态


        FOnProgress: TProgressEvent;
        FWebBrowserCommandStateChange:TWebBrowserCommandStateChangeEvent;
    protected
        function GetActive():boolean;
        procedure SetActive(IsActive:boolean);
        {-------------------------------------------------------------
        说明：传导
        --------------------------------------------------------------}
        procedure DoOnProgress( Progress,ProgressMax: Integer);dynamic;
        procedure DoWebBrowserCommandStateChange(Command: Integer; Enable: WordBool);dynamic;

    public
        constructor Create(const PageControl:TPageControl;AOwner: TComponent);
        destructor Destroy; override;
        //-------------------------------------------------------
        //  事件委托
        //-------------------------------------------------------
        procedure TabSheet1Resize(Sender: TObject); //调整Browse的宽度
        //在新窗口中打开
        procedure WebBrowserNewWindow2(Sender: TObject; var ppDisp: IDispatch;
        var Cancel: WordBool);
        //打开网页之前事件
        procedure WebBrowserBeforeNavigate2(Sender: TObject;
         const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
          Headers: OleVariant; var Cancel: WordBool);
        //下载完成文档
        procedure WebBrowserDocumentComplete(Sender: TObject;
            const pDisp: IDispatch; var URL: OleVariant);
        //打开完成
        procedure WebBrowserNavigateComplete2(Sender: TObject;
         const pDisp: IDispatch; var URL: OleVariant);
        //进度条
        procedure WebBrowserProgressChange(Sender: TObject; Progress,
            ProgressMax: Integer);
        //向前，向后按钮
        procedure WebBrowserCommandStateChange(Sender: TObject;
            Command: Integer; Enable: WordBool);
        //---------------------------------------------------



        //设置标题
        procedure SetCaption(Caption:string);
        function GetCaption:string;
        procedure SetURL(sURL:string);
        function GetURL:string;
        //新增一页
        function AddBrowsePage(sURL:String):boolean;overload;
        function AddBrowsePage(Caption:String;sUrl:string):boolean;overload;
        function AddBrowsePage():boolean;overload;
         //向前，向后，停止，刷新
        procedure Goback;
        procedure GoForward;
        procedure Refresh;
        procedure Stop;
        procedure SaveToHtmlFile(filename:string);
        procedure IeCommand(iCmd:integer);//1=查找，2=查看源码，3=选项设置
        //取得当前游览器对象
        function GetWebBrowser:TWebBrowser;
        //从字符串中加载
        procedure loadFormString(const HTML: string);
        //从流中加载
        procedure LoadFromStream(const Stream: TStream);
        //从接口中加入
        procedure InternalLoadDocumentFromStream(
          const Stream: TStream);
        //设置编码
        procedure SetCharSet(ACharSet: String);

        //
        function DeletePage(PageControl:TPageControl):boolean;   //删除这一页
        function GetDefaultDispatch: IDispatch; //返回调用接口
    published
        property OnProgress: TProgressEvent read FOnProgress write FOnProgress;
        property OnWebBrowserCommandStateChange: TWebBrowserCommandStateChangeEvent
             read FWebBrowserCommandStateChange write FWebBrowserCommandStateChange;
    end;
     {-------------------------------------------------------------
     说明：IE窗口管理类
     功能: 无
     作者：lihuizhan
     --------------------------------------------------------------}
    TIEManager=class
    private

        FPage:    TNewIEPage;
        FPageCtrol:TPageControl;
    public
       constructor Create(const PageControl:TPageControl);
       destructor Destroy; override;
       procedure NewPage(sURL:string;OnProgress: TProgressEvent;
            OnWebBrowserCommandStateChange:TWebBrowserCommandStateChangeEvent);
       procedure DeletePage(index:integer);
       function GetPage(index:integer):TNewIEPage;

    end;

{********************************************************************************}






var
    FBrowserList:TList;
    APage: TNewIEPage;
    procedure CreatePage(const PageControl:TPageControl;sURL:string;OnProgress: TProgressEvent);
implementation
////////////////////////////////////////////////////////////////////////////////
{ TNewIEPage }
//新增一页
function TNewIEPage.AddBrowsePage: boolean;
begin
    FsheetItem.Align:=alclient;
    FsheetItem.PageControl:=FpageControl;
    FsheetItem.Caption:='空白页';
    FsheetItem.Show;
    FWebBrowser:=TWebBrowser.Create(nil);
    FWebBrowser.ParentWindow:=FpageControl.Pages[FpageControl.PageCount-1].Handle;
    FWebBrowser.TheaterMode:=true;
    FWebBrowser.Align:=alclient;
    FWebBrowser.RegisterAsBrowser;
    FWebBrowser.Width :=FsheetItem.Width;
    FWebBrowser.Height :=FsheetItem.Height;
    FWebBrowser.Show;
    //----------------
    //事件委托
    //-----------------
    FsheetItem.OnResize:=TabSheet1Resize;
    FWebBrowser.OnNewWindow2:=WebBrowserNewWindow2;  //在新窗口中打开
    FWebBrowser.OnBeforeNavigate2:=WebBrowserBeforeNavigate2; //开始打开网页
    FWebBrowser.OnDocumentComplete:=WebBrowserNavigateComplete2;//下载网页文档完成
    FWebBrowser.OnProgressChange:= WebBrowserProgressChange;   //进度条事件
    FWebBrowser.OnCommandStateChange:=WebBrowserCommandStateChange;//向前向后的按钮控制


end;
//新增一页
function TNewIEPage.AddBrowsePage(sURL:String): boolean;
begin
    SetURL(sURL);
    AddBrowsePage;
    FWebBrowser.Navigate(FUrl);
end;
//新增一页
function TNewIEPage.AddBrowsePage(Caption,
  sUrl: string): boolean;
begin
     AddBrowsePage(Caption);
     FWebBrowser.Navigate(sUrl);

end;

//构造函数


constructor TNewIEPage.Create(const PageControl:TPageControl;AOwner: TComponent);
begin
    FHistoryList:=Tstringlist.Create;
    FsheetItem:=TTabSheet.Create(nil);
    FWebBrowser:=TWebBrowser.Create(nil);
    if PageControl<>nil then
    FpageControl :=PageControl;

    FIsActive := false;
    FGoBackState:=false;
end;

//静态函数
procedure CreatePage(const PageControl: TPageControl;sURL:string;
  OnProgress: TProgressEvent);
begin
     APage:=TNewIEPage.Create(PageControl,nil);
     APage.AddBrowsePage(sURL);
     APage.OnProgress:=OnProgress;
end;

//删除一页
function TNewIEPage.DeletePage(PageControl: TPageControl): boolean;
begin
    Destroy;
end;

//析构函数
destructor TNewIEPage.Destroy;
begin
    FHistoryList.Free;
    if FsheetItem<> nil then
    FsheetItem.Free;
    if FWebBrowser<> nil then
    FWebBrowser.free;
    FplClient.free;
    FpageControl.free;
    FOnProgress:=nil;
  inherited;
end;

procedure TNewIEPage.DoOnProgress( Progress,
  ProgressMax: Integer);
begin
    if assigned(FOnProgress) then
        FOnProgress(self,Progress,ProgressMax);
    //else  showmessage('FOnProgress is nil');
end;


procedure TNewIEPage.DoWebBrowserCommandStateChange(Command: Integer;
  Enable: WordBool);
begin
    if assigned(FOnProgress) then
        FWebBrowserCommandStateChange(self,Command,Enable);

end;

procedure TNewIEPage.IeCommand(iCmd:integer);
const
  CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
var
  CmdTarget : IOleCommandTarget;
  vaIn, vaOut: OleVariant;
  PtrGUID: PGUID;
begin
  New(PtrGUID);
  PtrGUID^ := CGID_WebBrowser;
  if FWebBrowser.Document <> nil then
    try
      FWebBrowser.Document.QueryInterface(IOleCommandTarget, CmdTarget);
      if CmdTarget <> nil then
        try
          CmdTarget.Exec( PtrGUID, iCmd, 0, vaIn, vaOut);
        finally
          CmdTarget._Release;
        end;
    except
      // Nothing
    end;
  Dispose(PtrGUID);
end;
function TNewIEPage.GetActive: boolean;
begin
   result:= FIsActive;
end;

function TNewIEPage.GetCaption: string;
begin
result:=self.FCaption;
end;

function TNewIEPage.GetDefaultDispatch: IDispatch;
begin
   result:= FWebBrowser.DefaultDispatch;
end;

function TNewIEPage.GetWebBrowser: TWebBrowser;
begin
    result:=FWebBrowser;
end;

procedure TNewIEPage.Goback;
begin
    try
      FWebBrowser.GoBack;
    except
    end;
end;

procedure TNewIEPage.GoForward;
begin

    try
        FWebBrowser.GoForward;
    except
    end;

end;

procedure TNewIEPage.Refresh;
begin
    FWebBrowser.Refresh;

end;

procedure TNewIEPage.SaveToHtmlFile(filename:string);
var
  HTMLDocument: IHTMLDocument2;
  PersistFile: IPersistFile;
begin
  HTMLDocument := FWebBrowser.Document as IHTMLDocument2;
  PersistFile := HTMLDocument as IPersistFile;
  PersistFile.Save(StringToOleStr(filename), True);

  //while HTMLDocument.readyState <> 'complete' do
  //  Application.ProcessMessages;

end;

procedure TNewIEPage.SetActive(IsActive: boolean);
begin
    FIsActive:=IsActive;
end;
procedure TNewIEPage.SetCaption(Caption: string);
begin
    FCaption:=Caption;
    if length(FCaption)>20 then
        FsheetItem.Caption:=copy(FCaption,0,20)+'......'
    else
        FsheetItem.Caption:=FCaption;
end;

procedure TNewIEPage.SetURL(sURL: string);
begin
FUrl:=sURL;
end;

procedure TNewIEPage.Stop;
begin
    FWebBrowser.Stop;
end;

procedure TNewIEPage.TabSheet1Resize(Sender: TObject);
begin
    FWebBrowser.Width :=FsheetItem.Width;
    FWebBrowser.Height :=FsheetItem.Height;
end;

procedure TNewIEPage.WebBrowserBeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
    NewIndex: Integer;
begin
    SetCaption(URL);
    SetURL(URL);
    // FHistroyUrl.Add(URL);//增加到历史
    {
    NewIndex := FHistoryList.IndexOf(URL);
    if NewIndex = -1 then
    begin
      if (FHistoryIndex >= 0) and (FHistoryIndex < FHistoryList.Count - 1) then
        while FHistoryList.Count > FHistoryIndex do
          FHistoryList.Delete(FHistoryIndex);
      FHistoryIndex := FHistoryList.Add(URL);
    end
    else
      FHistoryIndex := NewIndex;
     }

end;


procedure TNewIEPage.WebBrowserCommandStateChange(Sender: TObject;
  Command: Integer; Enable: WordBool);
begin
   { case Command of
        CSC_NAVIGATEBACK: Button1.Enabled := Enable;
        CSC_NAVIGATEFORWARD: Button2.Enabled := Enable;
    end; }
    DoWebBrowserCommandStateChange(Command,Enable);
end;

procedure TNewIEPage.WebBrowserDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
   SetCaption(FWebBrowser.OleObject.Document.Title);
   
end;

procedure TNewIEPage.WebBrowserNavigateComplete2(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
   SetCaption(FWebBrowser.OleObject.Document.Title);
end;

procedure TNewIEPage.WebBrowserNewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
var
    h:THandle;
    s:pchar;
begin
   // showmessage();
   // FCount:=FCount+1;
  // if FCount=1 then
   //begin
   FPageControl.Update;
   APage:=TNewIEPage.Create(FPageControl,nil);
   APage.AddBrowsePage(FUrl);
   ppDisp:=APage.GetDefaultDispatch;
   APage.OnProgress:=FOnProgress;//Form1.OnProgress;
   APage.OnWebBrowserCommandStateChange:=FWebBrowserCommandStateChange;
   FBrowserList.Add(APage);
   //end
   //else
   // begin
        //FWebBrowser.GetTextBuf(s,8000);
        //showmessage(s);
       //h:=(sender as TWebBrowser).HWND;
       //h:=findwindow(nil,pchar(FCaption)) ;
      // PostMessage(h,wm_close,0,0);
   //end;
end;

//事件委托
procedure TNewIEPage.WebBrowserProgressChange(Sender: TObject; Progress,
  ProgressMax: Integer);
begin

  DoOnProgress(Progress,ProgressMax);
end;

{ TIEManager }

constructor TIEManager.Create(const PageControl: TPageControl);
begin
    FPageCtrol:=PageControl;
    FBrowserList:=TList.Create;
end;

//删除一页
procedure TIEManager.DeletePage(index: integer);
begin

    if FBrowserList.Count>=0 then
    begin
        FPageCtrol.Pages[index].Destroy;
        FBrowserList.Delete(index);

    end;

end;

destructor TIEManager.Destroy;
begin
  //FBrowserList.Free;
  inherited;
end;

function TIEManager.GetPage(index: integer): TNewIEPage;
begin
    result:=FBrowserList[index];
end;

procedure TIEManager.NewPage(sURL:string;OnProgress: TProgressEvent;
    OnWebBrowserCommandStateChange:TWebBrowserCommandStateChangeEvent);
begin
     FPage:=TNewIEPage.Create(FPageCtrol,nil);
     FPage.AddBrowsePage(sURL);

     FPage.OnProgress:=OnProgress;
     //
     FBrowserList.Add(FPage);
     FPage.OnWebBrowserCommandStateChange:=OnWebBrowserCommandStateChange;

end;



function TNewIEPage.GetURL: string;
begin
    result:=self.FUrl;
end;

procedure TNewIEPage.loadFormString(const HTML: string);
var
  StringStream: TStringStream;
begin
  StringStream := TStringStream.Create(HTML);
  try
    LoadFromStream(StringStream);
  finally
    StringStream.Free;
  end;
end;

procedure TNewIEPage.LoadFromStream(const Stream: TStream);
begin
  FWebBrowser.Navigate('about:blank');
  InternalLoadDocumentFromStream(Stream);

end;

procedure TNewIEPage.InternalLoadDocumentFromStream(const Stream: TStream);
var
  PersistStreamInit: IPersistStreamInit;
  StreamAdapter: IStream;
begin
  Assert(Assigned(FWebBrowser.Document));
  // Get IPersistStreamInit interface on document object
  if FWebBrowser.Document.QueryInterface(
    IPersistStreamInit, PersistStreamInit
  ) = S_OK then
  begin
    // Clear document
    if PersistStreamInit.InitNew = S_OK then
    begin
      // Get IStream interface on stream
      StreamAdapter:= TStreamAdapter.Create(Stream);
      // Load data from Stream into WebBrowser
      PersistStreamInit.Load(StreamAdapter);
    end;
  end;
end;

procedure TNewIEPage.SetCharSet(ACharSet: String);
var
    RefreshLevel: OleVariant;
Begin
    IHTMLDocument2(FWebBrowser.Document).Set_CharSet(ACharSet);
    RefreshLevel :=7;
    FWebBrowser.Refresh2(RefreshLevel);
End;
end.