uses
..., OleCtrls, SHDocVw, mshtml;
type
THTMLEventNotifyEvent = procedure(EventObject: IHTMLEventObj; EventType: string) of object;
THTMLEvent = class(TInterfacedObject, IDispatch)
private
FDocument: IHTMLDocument2;
FOnEvent: THTMLEventNotifyEvent;
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;
procedure DoEvent;
public
constructor Create(Document: IHTMLDocument2);
property OnEvent: THTMLEventNotifyEvent read FOnEvent write FOnEvent;
end;
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
Memo1: TMemo;
...
private
...
procedure KeyEvent(EventObject: IHTMLEventObj; EventType: string);
public
...
end;
...
implementation
function THTMLEvent.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL
end;
function THTMLEvent.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
Result := E_NOTIMPL
end;
function THTMLEvent.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL
end;
function THTMLEvent.Invoke(dispid: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
DoEvent;
Result := S_OK;
end;
constructor THTMLEvent.Create(Document: IHTMLDocument2);
begin
inherited Create;
FDocument := Document;
FOnEvent := nil;
end;
procedure THTMLEvent.DoEvent;
var
EventObj: IHTMLEventObj;
EventType: string;
begin
if Assigned(FOnEvent) then
begin
EventObj := nil;
EventType := '';
if Assigned(FDocument) and Assigned(FDocument.parentWindow) then
begin
EventObj := FDocument.parentWindow.event;
if Assigned(EventObj) then
EventType := EventObj.type_;
end;
FOnEvent(EventObj, EventType);
end;
end;
{ TForm1 }
procedure TForm1.KeyEvent(EventObject: IHTMLEventObj; EventType: string);
var
attr: OleVariant;
begin
Memo1.Clear;
Memo1.Lines.Add('Type of Event: ' + EventType);
Memo1.Lines.Add('Element tagName: ' + EventObject.srcElement.tagName);
attr := EventObject.srcElement.getAttribute('type', 0);
if attr <> Null then
Memo1.Lines.Add('Element type: ' + attr);
EventObject.cancelBubble := true;
EventObject.returnValue := false;
end;
procedure TForm1.<SomeProc>(Sender: TObject);
var
Doc: IHTMLDocument2;
EventHandler: THTMLEvent;
begin
Memo1.Clear;
WebBrowser1.Navigate('http://SomePage.ru');
repeat
application.ProcessMessages;
until WebBrowser1.ReadyState >= READYSTATE_COMPLETE;
Doc := WebBrowser1.Document as IHTMLDocument2;
EventHandler := THTMLEvent.Create(Doc);
EventHandler.OnEvent := KeyEvent;
Doc.onclick := EventHandler as IDispatch;
Doc.onkeydown := EventHandler as IDispatch;
Doc.onkeypress := EventHandler as IDispatch;
Doc.onkeyup := EventHandler as IDispatch; //etc.
end;