unit WebEvent;
{*****************************************************************
拦截Web页面上的事件的组件 by Lichaohui 2002-12-21
*****************************************************************}
interface
uses
Windows, Messages, SysUtils, Classes, ActiveX, ComObj,
OleCtrls, SHDocVw, {$IFDEF LZH911}StrCtn,{$ENDIF} MsHtml;
type
{ $message '支持多种事件添加模式,目前尚没有完成'}
//TAttachMode = (etAttach, etInstead, etConnect);
TWebEvt = procedure(Sender: IWebBrowser; event: OleVariant;
SrcElement: OleVariant) of object;
TWebEvents = class;
TWebEventItem = class;
{ TWebEvent }
TWebEvent = class(TComponent, IUnknown, IDispatch)
private
FEvtSource: IWebBrowser;
FWebEvents: TWebEvents;
//Fatm: TAttachMode;
procedure SetEvtSource(const Value: IWebBrowser);
procedure SetWebEvents(const Value: TWebEvents);
{$IFDEF LZH911}
function GetAboutStr: TAboutString;
procedure SetAboutStr(const Value: TAboutString);
{$ENDIF}
function GetEtf: String;
function GetObjLst: String;
function GetPgs: String;
function GetStg: String;
procedure SetEtf(const Value: String);
procedure SetObjLst(const Value: String);
procedure SetPgs(const Value: String);
procedure SetStg(const Value: String);
function GetOnEvent: TWebEvt;
procedure SetOnEvent(const Value: TWebEvt);
protected
DefEvent: TWebEvents;
procedure CheckDef;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function MatchPage(PageName: String): Boolean;
procedure AttachEvents;
published
{$IFDEF LZH911}
property About: TAboutString read GetAboutStr write SetAboutStr stored 0;
{$ENDIF}
property EvtSource: IWebBrowser read FEvtSource write SetEvtSource;
property OnEvent: TWebEvt read GetOnEvent write SetOnEvent;
property StandardTags: String read GetStg write SetStg;
property ObjectList: String read GetObjLst write SetObjLst;
property EventsToFire: String read GetEtf write SetEtf;
property PagesToRecv: String read GetPgs write SetPgs;
//property AttachMode: TAttachMode read Fatm write Fatm;
property WebEvents: TWebEvents read FWebEvents write SetWebEvents;
end;
{ TWebEvents }
TWebEvents = class(TCollection)
private
FOwner: TWebEvent;
function GetItem(Idx: Integer): TWebEventItem;
procedure SetItem(Idx: Integer; const Value: TWebEventItem);
protected
procedure Update(Item: TCollectionItem); override;
function GetOwner: TPersistent; override;
public
constructor Create(AOwner: TWebEvent);
function Add: TWebEventItem;
property Items[Idx: Integer]: TWebEventItem read GetItem write SetItem; default;
end;
{ TWebEventItem }
TWebEventItem = class(TCollectionItem, IUnknown, IDispatch)
private
FOnEvent: TWebEvt;
FObjLst: String;
FPgs: String;
FEtf: String;
FStg: String;
FPages: TStringList;
FEvents: TStringList;
FSdTags: TStringList;
FObjects: TStringList;
//Fatm: TAttachMode;
function GetEvtSource: IWebBrowser;
procedure SetEtf(const Value: String);
procedure SetObjLst(const Value: String);
procedure SetPgs(const Value: String);
procedure SetStg(const Value: String);
protected
FRefCount: Integer;
{ IUnknown }
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
{ IDispatch }
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;
// Call by innternal
procedure InitAttach;
function InPages(PageName: String): Boolean;
function InTags(TagName: String): Boolean;
function InEvts(EvtName: String): Boolean;
function InObjs(ObjName: String): Boolean;
procedure FinitAttach;
procedure AttachDocEvents(ADoc: IDispatch);
procedure AttachExtraEvents;
procedure AttachFrameEvents;
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure AttachEvents;
function MatchPage(PageName: String): Boolean;
property EvtSource: IWebBrowser read GetEvtSource;
published
property OnEvent: TWebEvt read FOnEvent write FOnEvent;
property StandardTags: String read FStg write SetStg;
property ObjectList: String read FObjLst write SetObjLst;
property EventsToFire: String read FEtf write SetEtf;
property PagesToRecv: String read FPgs write SetPgs;
//property AttachMode: TAttachMode read Fatm write Fatm;
end;
{$IFNDEF LZH911}
procedure Register;
{$ENDIF}
implementation
{$IFNDEF LZH911}
procedure Register;
begin
//安装组件到系统页
RegisterComponents('System', [TWebEvent]);
end;
{$ENDIF}
{ TWebEvent }
constructor TWebEvent.Create(AOwner: TComponent);
begin
FWebEvents := TWebEvents.Create(Self);
DefEvent := TWebEvents.Create(Self);
inherited;
end;
destructor TWebEvent.Destroy;
begin
DefEvent.Free;
FWebEvents.Free;
inherited;
end;
procedure TWebEvent.SetEvtSource(const Value: IWebBrowser);
begin
FEvtSource := Value;
if Assigned(FEvtSource) then
begin
//FEvtSource.FreeNotification(Self);
end;
end;
procedure TWebEvent.Notification(AComponent: TComponent;
Operation: TOperation);
begin
inherited Notification(AComponent, Operation);
//if (Operation = opRemove) and (AComponent = FEvtSource) then
// FEvtSource := nil;
end;
procedure TWebEvent.AttachEvents;
var
i: Integer;
begin
for i := 0 to DefEvent.Count - 1 do
DefEvent.AttachEvents;
for i := 0 to FWebEvents.Count - 1 do
FWebEvents.AttachEvents;
end;
function TWebEvent.MatchPage(PageName: String): Boolean;
var
s: String;
p: Integer;
st: TStrings;
begin
s := LowerCase(Trim(ExtractFileName(PageName)));
p := Pos('.', s);
if p > 0 then s := Copy(s, 1, p - 1);
st := TStringList.Create;
try
st.CommaText := StringReplace(PagesToRecv, ';', ',', [rfReplaceAll]);
Result := (st.Count = 0) or (st.IndexOf(s) >= 0);
finally
st.Free;
end;
end;
procedure TWebEvent.SetWebEvents(const Value: TWebEvents);
begin
FWebEvents.Assign(Value);
end;
{$IFDEF LZH911}
function TWebEvent.GetAboutStr: TAboutString;
begin
Result := GetAboutString1;
end;
procedure TWebEvent.SetAboutStr(const Value: TAboutString);
begin
{ do nothing };
end;
{$ENDIF}
function TWebEvent.GetEtf: String;
begin
CheckDef;
Result := DefEvent.Items[0].EventsToFire;
end;
function TWebEvent.GetObjLst: String;
begin
CheckDef;
Result := DefEvent.Items[0].ObjectList;
end;
function TWebEvent.GetPgs: String;
begin
CheckDef;
Result := DefEvent.Items[0].PagesToRecv;
end;
function TWebEvent.GetStg: String;
begin
CheckDef;
Result := DefEvent.Items[0].StandardTags;
end;
procedure TWebEvent.SetEtf(const Value: String);
begin
CheckDef;
DefEvent.Items[0].EventsToFire := Value;
end;
procedure TWebEvent.SetObjLst(const Value: String);
begin
CheckDef;
DefEvent.Items[0].ObjectList := Value;
end;
procedure TWebEvent.SetPgs(const Value: String);
begin
CheckDef;
DefEvent.Items[0].PagesToRecv := Value;
end;
procedure TWebEvent.SetStg(const Value: String);
begin
CheckDef;
DefEvent.Items[0].StandardTags := Value;
end;
procedure TWebEvent.CheckDef;
begin
if DefEvent.Count < 1 then DefEvent.Add;
end;
function TWebEvent.GetOnEvent: TWebEvt;
begin
CheckDef;
Result := DefEvent.Items[0].OnEvent;
end;
procedure TWebEvent.SetOnEvent(const Value: TWebEvt);
begin
CheckDef;
DefEvent.Items[0].OnEvent := Value;
end;
{ TWebEvents }
function TWebEvents.Add: TWebEventItem;
begin
Result:=TWebEventItem(inherited Add);
end;
constructor TWebEvents.Create(AOwner: TWebEvent);
begin
inherited Create(TWebEventItem);
FOwner := AOwner;
end;
function TWebEvents.GetItem(Idx: Integer): TWebEventItem;
begin
Result := TWebEventItem(inherited GetItem(Idx));
end;
function TWebEvents.GetOwner: TPersistent;
begin
Result := FOwner;
end;
procedure TWebEvents.SetItem(Idx: Integer; const Value: TWebEventItem);
begin
inherited SetItem(Idx, Value);
end;
procedure TWebEvents.Update(Item: TCollectionItem);
begin
inherited;
end;
{ TWebEventItem }
constructor TWebEventItem.Create(Collection: TCollection);
begin
inherited;
end;
destructor TWebEventItem.Destroy;
begin
FinitAttach;
inherited;
end;
function TWebEventItem._AddRef: Integer;
begin
Inc(FRefCount);
Result := FRefCount;
end;
function TWebEventItem._Release: Integer;
begin
Dec(FRefCount);
Result := FRefCount;
end;
function TWebEventItem.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := S_OK
else
Result := E_NOINTERFACE;
end;
function TWebEventItem.GetTypeInfoCount(out Count: Integer): HResult;
begin
Count := 0;
Result := S_OK;
end;
function TWebEventItem.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Pointer(TypeInfo) := nil;
Result := E_NOTIMPL;
end;
function TWebEventItem.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TWebEventItem.Invoke(DispID: Integer; const IID: TGUID;
LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
var
vDoc: OleVariant;
vEle: OleVariant;
vEvt: OleVariant;
begin
Result := S_OK;
if Assigned(FOnEvent) and Assigned(EvtSource) then
begin
vDoc := EvtSource.Document;
vEvt := vDoc.parentWindow.event;
vEle := vEvt.srcElement;
FOnEvent(EvtSource, vEvt, vEle);
end;
end;
procedure TWebEventItem.AttachEvents;
var
Doc: IDispatch;
begin
{ $message '此方法需要进一步优化,加快速度和避免重复触发'
程序的目的,扫描页面中的所有元素,给符合条件的
设定事件,此外还需要对特殊对象的事件进行处理
如:document,window 目前仅处理这两个
目前,已经将IndexOf 改为Find了,进行排序后的二分查找,
可以从一定程度上加快速度
}
if not Assigned(EvtSource) then Exit;
//准备进行扫描,初始化扫描过程
InitAttach;
try
Doc := EvtSource.Document;
if Assigned(Doc) then
begin
//给特殊对象的事件赋值
AttachExtraEvents;
AttachFrameEvents;
AttachDocEvents(Doc);
end; //if Assigned(Doc)
//结束扫描
finally
//结束扫描,释放无用的对象
FinitAttach;
end;
end;
function TWebEventItem.MatchPage(PageName: String): Boolean;
var
s: String;
p: Integer;
st: TStrings;
begin
s := LowerCase(Trim(ExtractFileName(PageName)));
p := Pos('.', s);
if p > 0 then s := Copy(s, 1, p - 1);
st := TStringList.Create;
try
st.CommaText := StringReplace(PagesToRecv, ';', ',', [rfReplaceAll]);
Result := (st.Count = 0) or (st.IndexOf(s) >= 0);
finally
st.Free;
end;
end;
procedure TWebEventItem.FinitAttach;
begin
if Assigned(FPages) then FreeAndNil(FPages);
if Assigned(FSdTags) then FreeAndNil(FSdTags);
if Assigned(FObjects) then FreeAndNil(FObjects);
if Assigned(FEvents) then FreeAndNil(FEvents);
end;
procedure TWebEventItem.InitAttach;
begin
if not Assigned(FPages) then FPages := TStringList.Create;
if not Assigned(FSdTags) then FSdTags := TStringList.Create;
if not Assigned(FObjects) then FObjects := TStringList.Create;
if not Assigned(FEvents) then FEvents := TStringList.Create;
FPages.CommaText := StringReplace(LowerCase(FPgs), ';', ',', [rfReplaceAll]);
FSdTags.CommaText := StringReplace(LowerCase(FStg), ';', ',', [rfReplaceAll]);
FObjects.CommaText := StringReplace(LowerCase(FObjLst), ';', ',', [rfReplaceAll]);
FEvents.CommaText := StringReplace(LowerCase(FEtf), ';', ',', [rfReplaceAll]);
FPages.Sort;
FSdTags.Sort;
FObjects.Sort;
FEvents.Sort;
end;
function TWebEventItem.InEvts(EvtName: String): Boolean;
var
DummyInt: Integer;
begin
//Result := FEvents.IndexOf(LowerCase(EvtName)) >= 0;
Result := FEvents.Find(EvtName, DummyInt);
end;
function TWebEventItem.InObjs(ObjName: String): Boolean;
var
DummyInt: Integer;
begin
//Result := FObjects.IndexOf(LowerCase(ObjName)) >= 0;
Result := FObjects.Find(ObjName, DummyInt);
end;
function TWebEventItem.InPages(PageName: String): Boolean;
var
PgName: String;
t: Integer;
begin
PgName := LowerCase(ExtractFileName(PageName));
t := Pos('.', PgName);
if t > 0 then PgName := Copy(PgName, 1, t - 1);
//Result := (FPages.IndexOf(PgName) >= 0) or (FPages.Count = 0);
Result := (FPages.Count = 0) or FPages.Find(PgName, t);
end;
function TWebEventItem.InTags(TagName: String): Boolean;
var
t: Integer;
begin
//Result := FSdTags.IndexOf(LowerCase(TagName)) >= 0;
Result := FSdTags.Find(LowerCase(TagName), t);
end;
procedure TWebEventItem.AttachExtraEvents;
var
vDoc2: IHTMLDocument2;
vDoc3: IHTMLDocument3;
vWin: IHTMLWindow3;
ew, ed: Boolean;
i: Integer;
begin
//注意此过程仅在InitAttach和FinitAttach之间调用
if not Assigned(EvtSource) then Exit;
vDoc2 := EvtSource.Document as IHTMLDocument2;
if Assigned(vDoc2) then
begin
vWin := vDoc2.parentWindow as IHTMLWindow3;
vDoc3 := vDoc2 as IHTMLDocument3;
end;
//ew := FSdTags.IndexOf('window') >= 0;
ew := FSdTags.Find('window', i);
//ed := FSdTags.IndexOf('document') >= 0;
ed := FSdTags.Find('document', i);
if Assigned(vWin) and ew then
begin
for i := 0 to FEvents.Count - 1 do
vWin.attachEvent(FEvents, Self as IDispatch);
end;
if Assigned(vDoc3) and ed then
begin
for i := 0 to FEvents.Count - 1 do
vDoc3.attachEvent(FEvents, Self as IDispatch);
end;
end;
procedure TWebEventItem.AttachFrameEvents;
var
vDoc: IHTMLDocument2;
nDoc: IHTMLDocument2;
nDoc3: IHTMLDocument3;
vWin: IDispatch;
vWin2: IHTMLWindow2;
vWin3: IHTMLWindow3;
idx: OleVariant;
ew, ed: Boolean;
i, j: Integer;
begin
if not Assigned(EvtSource) then Exit;
try
vDoc := EvtSource.Document as IHTMLDocument2;
ew := FSdTags.IndexOf('window') >= 0;
ed := FSdTags.IndexOf('document') >= 0;
for i := 0 to vDoc.frames.length - 1 do
begin
//遍历所有框架
idx := i;
vWin := vDoc.frames.item(idx);
if Assigned(vWin) then
begin
vWin2 := vWin as IHTMLWindow2;
vWin3 := vWin as IHTMLWindow3;
if Assigned(vWin2.document) then
begin
nDoc := vWin2.document;
nDoc3 := vDoc as IHTMLDocument3;
//对每个框架窗口,附加事件,并对其内部的文档附加事件
for j := 0 to FEvents.Count - 1 do
begin
if ew then vWin3.attachEvent(FEvents, Self as IDispatch);
if Assigned(nDoc3) and ed then
nDoc3.attachEvent(FEvents, Self as IDispatch);
end;
if Assigned(nDoc) then AttachDocEvents(nDoc);
end
else
begin
nDoc := nil;
nDoc3 := nil;
end;
end;
end;
except
{do nothing}
end;
end;
procedure TWebEventItem.AttachDocEvents(ADoc: IDispatch);
var
TagName, EleId: String;
vDoc: IHTMLDocument2;
Ele: IHTMLElement;
Ele2: IHTMLElement2;
i, j, t: Integer;
begin
vDoc := ADoc as IHTMLDocument2;
if Assigned(vDoc) and InPages(vDoc.url) then
begin
for i := 0 to vDoc.all.length - 1 do
begin
Ele := vDoc.all.item(i, 0) as IHTMLElement;
TagName := Ele.tagName;
EleId := Ele.id;
TagName := LowerCase(TagName);
EleId := LowerCase(EleId);
//if (FSdTags.IndexOf(TagName) >= 0) or
// (FObjects.IndexOf(EleId) >= 0) then
if (FSdTags.Find(TagName, t)) or
(FObjects.Find(EleId, t)) then
begin
Ele2 := Ele as IHTMLElement2;
for j := 0 to FEvents.Count - 1 do
begin
Ele2.attachEvent(FEvents[j], Self as IDispatch);
end; //for j
end; //if
end; //for i
end; //if InPages
end;
function TWebEventItem.GetEvtSource: IWebBrowser;
begin
//Result := TWebEvents(GetOwner).FOwner.FEvtSource;
Result := TWebEvents(GetOwner).FOwner.FEvtSource;
end;
procedure TWebEventItem.Assign(Source: TPersistent);
begin
inherited;
FOnEvent := TWebEventItem(Source).FOnEvent;
FObjLst := TWebEventItem(Source).FObjLst;
FPgs := TWebEventItem(Source).FPgs;
FEtf := TWebEventItem(Source).FEtf;
FStg := FStg;
end;
procedure TWebEventItem.SetEtf(const Value: String);
begin
FEtf := Trim(StringReplace(LowerCase(Value), ',', ';', [rfReplaceAll]));
end;
procedure TWebEventItem.SetObjLst(const Value: String);
begin
FObjLst := Trim(StringReplace(LowerCase(Value), ',', ';', [rfReplaceAll]));
end;
procedure TWebEventItem.SetPgs(const Value: String);
begin
FPgs := Trim(StringReplace(LowerCase(Value), ',', ';', [rfReplaceAll]));
end;
procedure TWebEventItem.SetStg(const Value: String);
begin
FStg := Trim(StringReplace(LowerCase(Value), ',', ';', [rfReplaceAll]));
end;
end.