Kopiuj
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, OleCtrls, SHDocVw, MSHTML, StdCtrls, ActiveX;
type
TOnElementClickEvent = procedure(Sender: TObject; Element: IHTMLElement) of object;
TWebBrowser = class(SHDocVw.TWebbrowser, IDispatch)
private
FOnElementClickEvent: TOnElementClickEvent;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall;
procedure DocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
public
procedure LoadHTMLFromStrings(AHTML: TStrings);
property OnElementClickEvent: TOnElementClickEvent read FOnElementClickEvent write FOnElementClickEvent;
constructor Create(AOwner: TComponent); override;
end;
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
Memo1: TMemo;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
procedure WebBrowserElementClick(Sender: TObject; Element: IHTMLElement);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function TWebBrowser.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;
var
Doc: IHTMLDocument2;
Element: IHTMLElement;
begin
case DispID of
0: begin
Doc:= Document as IHTMLDocument2;
if Assigned(Doc) then
begin
Element:= Doc.activeElement;
if Assigned(Element) and Assigned(FOnElementClickEvent) then
FOnElementClickEvent(Self, Element);
end;
Result:= S_OK;
end;
else
Result:= inherited Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
end;
end;
procedure TWebBrowser.LoadHTMLFromStrings(AHTML: TStrings);
var
StringStream: TStringStream;
PersistStreamInit: IPersistStreamInit;
begin
if not Assigned(Document) then
begin
Navigate('about:blank');
while ReadyState <> READYSTATE_COMPLETE do
begin
Forms.Application.ProcessMessages;
end;
end;
if (Document.QueryInterface(IPersistStreamInit, PersistStreamInit) = S_OK) then
begin
if (PersistStreamInit.InitNew <> S_OK) then exit;
StringStream:= TStringStream.Create(AHTML.Text);
try
PersistStreamInit.Load(TStreamAdapter.Create(StringStream));
finally
StringStream.Free;
end;
end;
end;
procedure TWebBrowser.DocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
var
Doc: IHTMLDocument2;
begin
Doc:= Document as IHTMLDocument2;
OleVariant(Doc).attachEvent('onclick', OleVariant(Self as IDispatch));
inherited;
end;
constructor TWebBrowser.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
OnDocumentComplete:= DocumentComplete;
end;
procedure TForm1.WebBrowserElementClick(Sender: TObject; Element: IHTMLElement);
var
Link: string;
begin
if SameText(LowerCase(Element.tagName), 'a') then
begin
if Element.getAttribute('href', 0) <> null then
begin
Link:= Element.getAttribute('href', 0);
ShowMessage(Link);
WebBrowser1.Navigate(Link);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
WebBrowser1.OnElementClickEvent:= WebBrowserElementClick;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WebBrowser1.LoadHTMLFromStrings(Memo1.Lines);
end;
end.
Rozwiązanie ma jedną wadę WebBrowser nie pozwala na nadpisanie zdarzeń (metody można) więc jeżeli byś chciał do jakiegoś celu wykorzystać zdarzenie OnDocumentComplete
to aby to rozwiązanie działało koniecznie musisz w nim wstawić kod który podałem poniżej (jeżeli tego nie zrobisz to wykorzystane w powyższym kodzie zdarzenie OnDocumentComplete
się nie wykona a wiec nie zostanie przypisana metoda OnClick
do dokumentu dlatego bez tego kod nie będzie działał):