5,388
社区成员
发帖
与我相关
我的任务
分享
unit Unit11;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleCtrls, SHDocVw, ComCtrls;
type
TForm11 = class(TForm)
pgc1: TPageControl;
procedure FormCreate(Sender: TObject);
procedure pgc1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
function NewWindow(const URL : string = ''): TWebBrowser;
procedure MyBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
procedure MyNewWindow2(ASender: TObject; var ppDisp: IDispatch;
var Cancel: WordBool);
procedure closePage(aTab: TTabSheet);
{ Private declarations }
public
{ Public declarations }
end;
var
Form11: TForm11;
implementation
{$R *.dfm}
function TForm11.NewWindow(const URL : string = '') : TWebBrowser;
var
aTab : TTabSheet;
begin
aTab := TTabSheet.Create(pgc1);
aTab.PageControl := pgc1;
aTab.Caption := 'tab' + IntToStr(pgc1.PageCount);
pgc1.ActivePage := aTab;
aTab.Align := alClient;
result := TWebBrowser.Create(self);
aTab.InsertControl(result);
result.Align := alClient;
result.OnBeforeNavigate2 := MyBeforeNavigate2;
result.OnNewWindow2 := MyNewWindow2;
if URL <> '' then
result.Navigate(url);
end;
procedure TForm11.closePage(aTab : TTabSheet);
var
i : integer;
begin
if aTab = nil then Exit;
for I := aTab.ComponentCount - 1 downto 0 do
begin
if aTab.Components[i] is TWebBrowser then
TWebBrowser(aTab.Components[i]).Stop;
aTab.Components[i].Free;
end;
aTab.Free;
end;
procedure TForm11.pgc1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
Index: Integer;
begin
//左键点击并且双击
if (Button = mbLeft) and (ssDouble in Shift) then
begin
Index := pgc1.IndexOfTabAt(X, Y);
if Index >= 0 then
closePage(pgc1.Pages[Index]);
end;
end;
procedure TForm11.MyNewWindow2(ASender: TObject; var ppDisp: IDispatch;
var Cancel: WordBool);
begin
//新链接事件处理
ppDisp := NewWindow().DefaultInterface;
end;
procedure TForm11.FormCreate(Sender: TObject);
begin
NewWindow('http://news.baidu.com');
end;
procedure TForm11.MyBeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool);
begin
//Todo 事务处理
end;
end.