Sposób na nowe okno w WebBrowser

Sposób na nowe okno w WebBrowser


Witajcie :)
Tworzysz własnego browsera opartego na wb? Zapewne nie wiesz jak ugryźć problem z otwieraniem stron w nowym oknie.
Pragnę przedstawić kod, dzięki któremu sposób wyświetlania stron w nowych oknach będzie podobny do tego z IE ^^...
Każde nowe okno = nowa aplikacja.
Najczęstszym rozwiązaniem tegoż problemu jest kod:
 
var
  NewWindow: TForm1;
begin
  NewWindow := TForm1.Create(self);
  NewWindow.Show;
  ppDisp := NewWindow.Webbrowser1.DefaultDispatch; //Application
 

Chyba każdy zauważył, że formy są zależne od formy głównej na każdym kroku. Kiepsko...
Wpadłem na pomysł, aby nie tworzyć nowego okna, lecz otworzyć nową aplikację wraz z parametrem, w którym przekaże adres URL.
Cały kod (zainteresowani dostosują go do swojego programu):

 
unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,OleCtrls, SHDocVw, MSHTML, ActiveX, StdCtrls, ShellAPI;
 
type
TObjectProcedure = procedure of object;
  TEventObject = class(TInterfacedObject, IDispatch)
private
   FOnEvent: TObjectProcedure;
protected
   function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
   function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
   function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
   function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
public
   constructor Create(const OnEvent: TObjectProcedure) ;
   property OnEvent: TObjectProcedure read FOnEvent write FOnEvent;
   end;
 
type
  TForm1 = class(TForm)
    Button1: TButton;
    WebBrowser1: TWebBrowser;
    procedure WebBrowser1NewWindow2(Sender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure WebBrowser1DocumentComplete(Sender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
  private
    { Private declarations }
  public
    procedure OnMouseOver;
  end;
 
var
  Form1: TForm1;
  adr : string;
  htmlDoc : IHTMLDocument2;
 
implementation
 
{$R *.dfm}
constructor TEventObject.Create(const OnEvent: TObjectProcedure) ;
begin
   inherited Create;
   FOnEvent := OnEvent;
end;
 
function TEventObject.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
   Result := E_NOTIMPL;
end;
 
function TEventObject.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
   Result := E_NOTIMPL;
end;
 
function TEventObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
   Result := E_NOTIMPL;
end;
 
function TEventObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
   if (DispID = DISPID_VALUE) then
   begin
     if Assigned(FOnEvent) then FOnEvent;
     Result := S_OK;
   end
   else Result := E_NOTIMPL;
end;
procedure TForm1.OnMouseOver;
var
   element : IHTMLElement;
begin
   if htmlDoc = nil then Exit;
   element := htmlDoc.parentWindow.event.srcElement;
   if LowerCase(element.tagName) = 'a' then
   adr :=  element.getAttribute('href',0);
end;
 
procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
 
begin
 ppDisp := Webbrowser1.Application;
 ShellExecute(handle,'open',pchar(Application.Exename),pchar(adr),nil,sw_show);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
if paramCount > 0 then
  webbrowser1.navigate(paramStr(1));
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  webbrowser1.Navigate('http://google.pl');
end;
 
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  if Assigned(WebBrowser1.Document) then
   begin
     htmlDoc := WebBrowser1.Document as IHTMLDocument2;
     htmlDoc.onmouseover := (TEventObject.Create(OnMouseOver) as IDispatch) ;
   end;
end;
 
end.
 

Pozdrawiam,
Vecco :)

Kategoria: Delphi » Gotowce
Facebook
4programmers.net