Delphi 通过IConnectionPointContainer响应COM事件的例子，Internet Explorer 事件响应
来源：互联网 发布：数据共享交换平台 编辑：程序博客网 时间：2024/06/05 16:02
原文地址：http://www.swissdelphicenter.ch/torry/showcode.php?id=2058
示例下载：http://www.400gb.com/file/74984370
{ This component allows you to intercept Internet Explorer messages such as "StatusTextChangeEvent", "DocumentCompleteEvent" and so on. Mit folgende Komponente lassen sich Nachrichten wie "StatusTextChangeEvent", "DocumentCompleteEvent" usw. von Internet Explorer Fenstern abfangen. } //---- Component Source: Install this component first.unit IEEvents;interface uses Windows, SysUtils, Classes, Graphics, ComObj, ActiveX, SHDocVW;type // Event types exposed from the Internet Explorer interface TIEStatusTextChangeEvent = procedure(Sender: TObject; const Text: WideString) of object; TIEProgressChangeEvent = procedure(Sender: TObject; Progress: Integer; ProgressMax: Integer) of object; TIECommandStateChangeEvent = procedure(Sender: TObject; Command: Integer; Enable: WordBool) of object; TIEDownloadBeginEvent = procedure(Sender: TObject) of object; TIEDownloadCompleteEvent = procedure(Sender: TObject) of object; TIETitleChangeEvent = procedure(Sender: TObject; const Text: WideString) of object; TIEPropertyChangeEvent = procedure(Sender: TObject; const szProperty: WideString) of object; TIEBeforeNavigate2Event = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool) of object; TIENewWindow2Event = procedure(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool) of object; TIENavigateComplete2Event = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object; TIEDocumentCompleteEvent = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object; TIEOnQuitEvent = procedure(Sender: TObject) of object; TIEOnVisibleEvent = procedure(Sender: TObject; Visible: WordBool) of object; TIEOnToolBarEvent = procedure(Sender: TObject; ToolBar: WordBool) of object; TIEOnMenuBarEvent = procedure(Sender: TObject; MenuBar: WordBool) of object; TIEOnStatusBarEvent = procedure(Sender: TObject; StatusBar: WordBool) of object; TIEOnFullScreenEvent = procedure(Sender: TObject; FullScreen: WordBool) of object; TIEOnTheaterModeEvent = procedure(Sender: TObject; TheaterMode: WordBool) of object; // Event component for Internet Explorer TIEEvents = class(TComponent, IUnknown, IDispatch) private // Private declarations FConnected: Boolean; FCookie: Integer; FCP: IConnectionPoint; FSinkIID: TGuid; FSource: IWebBrowser2; FStatusTextChange: TIEStatusTextChangeEvent; FProgressChange: TIEProgressChangeEvent; FCommandStateChange: TIECommandStateChangeEvent; FDownloadBegin: TIEDownloadBeginEvent; FDownloadComplete: TIEDownloadCompleteEvent; FTitleChange: TIETitleChangeEvent; FPropertyChange: TIEPropertyChangeEvent; FBeforeNavigate2: TIEBeforeNavigate2Event; FNewWindow2: TIENewWindow2Event; FNavigateComplete2: TIENavigateComplete2Event; FDocumentComplete: TIEDocumentCompleteEvent; FOnQuit: TIEOnQuitEvent; FOnVisible: TIEOnVisibleEvent; FOnToolBar: TIEOnToolBarEvent; FOnMenuBar: TIEOnMenuBarEvent; FOnStatusBar: TIEOnStatusBarEvent; FOnFullScreen: TIEOnFullScreenEvent; FOnTheaterMode: TIEOnTheaterModeEvent; protected // Protected declaratios for IUnknown function QueryInterface(const IID: TGUID; out Obj): HResult; override; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; // Protected declaratios for IDispatch function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall; function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual; stdcall; // Protected declarations procedure DoStatusTextChange(const Text: WideString); safecall; procedure DoProgressChange(Progress: Integer; ProgressMax: Integer); safecall; procedure DoCommandStateChange(Command: Integer; Enable: WordBool); safecall; procedure DoDownloadBegin; safecall; procedure DoDownloadComplete; safecall; procedure DoTitleChange(const Text: WideString); safecall; procedure DoPropertyChange(const szProperty: WideString); safecall; procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool); safecall; procedure DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool); safecall; procedure DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant); safecall; procedure DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant); safecall; procedure DoOnQuit; safecall; procedure DoOnVisible(Visible: WordBool); safecall; procedure DoOnToolBar(ToolBar: WordBool); safecall; procedure DoOnMenuBar(MenuBar: WordBool); safecall; procedure DoOnStatusBar(StatusBar: WordBool); safecall; procedure DoOnFullScreen(FullScreen: WordBool); safecall; procedure DoOnTheaterMode(TheaterMode: WordBool); safecall; public // Public declarations constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure ConnectTo(Source: IWebBrowser2); procedure Disconnect; property SinkIID: TGuid read FSinkIID; property Source: IWebBrowser2 read FSource; published // Published declarations property WebObj: IWebBrowser2 read FSource; property Connected: Boolean read FConnected; property StatusTextChange: TIEStatusTextChangeEvent read FStatusTextChange write FStatusTextChange; property ProgressChange: TIEProgressChangeEvent read FProgressChange write FProgressChange; property CommandStateChange: TIECommandStateChangeEvent read FCommandStateChange write FCommandStateChange; property DownloadBegin: TIEDownloadBeginEvent read FDownloadBegin write FDownloadBegin; property DownloadComplete: TIEDownloadCompleteEvent read FDownloadComplete write FDownloadComplete; property TitleChange: TIETitleChangeEvent read FTitleChange write FTitleChange; property PropertyChange: TIEPropertyChangeEvent read FPropertyChange write FPropertyChange; property BeforeNavigate2: TIEBeforeNavigate2Event read FBeforeNavigate2 write FBeforeNavigate2; property NewWindow2: TIENewWindow2Event read FNewWindow2 write FNewWindow2; property NavigateComplete2: TIENavigateComplete2Event read FNavigateComplete2 write FNavigateComplete2; property DocumentComplete: TIEDocumentCompleteEvent read FDocumentComplete write FDocumentComplete; property OnQuit: TIEOnQuitEvent read FOnQuit write FOnQuit; property OnVisible: TIEOnVisibleEvent read FOnVisible write FOnVisible; property OnToolBar: TIEOnToolBarEvent read FOnToolBar write FOnToolBar; property OnMenuBar: TIEOnMenuBarEvent read FOnMenuBar write FOnMenuBar; property OnStatusBar: TIEOnStatusBarEvent read FOnStatusBar write FOnStatusBar; property OnFullScreen: TIEOnFullScreenEvent read FOnFullScreen write FOnFullScreen; property OnTheaterMode: TIEOnTheaterModeEvent read FOnTheaterMode write FOnTheaterMode; end;// Register procedureprocedure Register;implementation function TIEEvents._AddRef: Integer;begin // No more than 2 counts result := 2;end;function TIEEvents._Release: Integer;begin // Always maintain 1 ref count (component holds the ref count) result := 1;end;function TIEEvents.QueryInterface(const IID: TGUID; out Obj): HResult;begin // Clear interface pointer Pointer(Obj) := nil; // Attempt to get the requested interface if (GetInterface(IID, Obj)) then // Success result := S_OK // Check to see if the guid requested is for the event else if (IsEqualIID(IID, FSinkIID)) then begin // Event is dispatch based, so get dispatch interface (closest we can come) if (GetInterface(IDispatch, Obj)) then // Success result := S_OK else // Failure result := E_NOINTERFACE; end else // Failure result := E_NOINTERFACE;end;function TIEEvents.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;begin // Not implemented result := E_NOTIMPL;end;function TIEEvents.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;begin // Clear the result interface Pointer(TypeInfo) := nil; // No type info for our interface result := E_NOTIMPL;end;function TIEEvents.GetTypeInfoCount(out Count: Integer): HResult;begin // Zero type info counts Count := 0; // Return success result := S_OK;end;function TIEEvents.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;var pdpParams: PDispParams; lpDispIDs: array[0..63] of TDispID; dwCount: Integer;begin // Get the parameters pdpParams := @Params; // Events can only be called with method dispatch, not property get/set if ((Flags and DISPATCH_METHOD) > 0) then begin // Clear DispID list ZeroMemory(@lpDispIDs, SizeOf(lpDispIDs)); // Build dispatch ID list to handle named args if (pdpParams^.cArgs > 0) then begin // Reverse the order of the params because they are backwards for dwCount := 0 to Pred(pdpParams^.cArgs) do lpDispIDs[dwCount] := Pred(pdpParams^.cArgs) - dwCount; // Handle named arguments if (pdpParams^.cNamedArgs > 0) then begin for dwCount := 0 to Pred(pdpParams^.cNamedArgs) do lpDispIDs[pdpParams^.rgdispidNamedArgs^[dwCount]] := dwCount; end; end; // Unless the event falls into the "else" clause of the case statement the result is S_OK result := S_OK; // Handle the event case DispID of 102: DoStatusTextChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval); 104: DoDownloadComplete; 105: DoCommandStateChange(pdpParams^.rgvarg^[lpDispIds[0]].lval, pdpParams^.rgvarg^[lpDispIds[1]].vbool); 106: DoDownloadBegin; 108: DoProgressChange(pdpParams^.rgvarg^[lpDispIds[0]].lval, pdpParams^.rgvarg^[lpDispIds[1]].lval); 112: DoPropertyChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval); 113: DoTitleChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval); 250: DoBeforeNavigate2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval), POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[2]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[3]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[4]].pvarval)^, POleVariant(pdpParams^.rgvarg^[lpDispIds[5]].pvarval)^, pdpParams^.rgvarg^[lpDispIds[6]].pbool^); 251: DoNewWindow2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].pdispval^), pdpParams^.rgvarg^[lpDispIds[1]].pbool^); 252: DoNavigateComplete2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval), POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^); 253: begin // Special case handler. When Quit is called, IE is going away so we might // as well unbind from the interface by calling disconnect. DoOnQuit; // Call disconnect Disconnect; end; 254: DoOnVisible(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 255: DoOnToolBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 256: DoOnMenuBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 257: DoOnStatusBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 258: DoOnFullScreen(pdpParams^.rgvarg^[lpDispIds[0]].vbool); 259: DoDocumentComplete(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval), POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^); 260: DoOnTheaterMode(pdpParams^.rgvarg^[lpDispIds[0]].vbool); else // Have to idea of what event they are calling result := DISP_E_MEMBERNOTFOUND; end; end else // Called with wrong flags result := DISP_E_MEMBERNOTFOUND;end;constructor TIEEvents.Create(AOwner: TComponent);begin // Perform inherited inherited Create(AOwner); // Set the event sink IID FSinkIID := DWebBrowserEvents2;end;destructor TIEEvents.Destroy;begin // Disconnect Disconnect; // Perform inherited inherited Destroy;end;procedure TIEEvents.ConnectTo(Source: IWebBrowser2);var pvCPC: IConnectionPointContainer;begin // Disconnect from any currently connected event sink Disconnect; // Query for the connection point container and desired connection point. // On success, sink the connection point OleCheck(Source.QueryInterface(IConnectionPointContainer, pvCPC)); OleCheck(pvCPC.FindConnectionPoint(FSinkIID, FCP)); OleCheck(FCP.Advise(Self, FCookie)); // Update internal state variables FSource := Source; // We are in a connected state FConnected := True; // Release the temp interface pvCPC := nil;end;procedure TIEEvents.Disconnect;begin // Do we have the IWebBrowser2 interface? if Assigned(FSource) then begin try // Unadvise the connection point OleCheck(FCP.Unadvise(FCookie)); // Release the interfaces FCP := nil; FSource := nil; except Pointer(FCP) := nil; Pointer(FSource) := nil; end; end; // Disconnected state FConnected := False;end;procedure TIEEvents.DoStatusTextChange(const Text: WideString);begin // Call assigned event if Assigned(FStatusTextChange) then FStatusTextChange(Self, Text);end;procedure TIEEvents.DoProgressChange(Progress: Integer; ProgressMax: Integer);begin // Call assigned event if Assigned(FProgressChange) then FProgressChange(Self, Progress, ProgressMax);end;procedure TIEEvents.DoCommandStateChange(Command: Integer; Enable: WordBool);begin // Call assigned event if Assigned(FCommandStateChange) then FCommandStateChange(Self, Command, Enable);end;procedure TIEEvents.DoDownloadBegin;begin // Call assigned event if Assigned(FDownloadBegin) then FDownloadBegin(Self);end;procedure TIEEvents.DoDownloadComplete;begin // Call assigned event if Assigned(FDownloadComplete) then FDownloadComplete(Self);end;procedure TIEEvents.DoTitleChange(const Text: WideString);begin // Call assigned event if Assigned(FTitleChange) then FTitleChange(Self, Text);end;procedure TIEEvents.DoPropertyChange(const szProperty: WideString);begin // Call assigned event if Assigned(FPropertyChange) then FPropertyChange(Self, szProperty);end;procedure TIEEvents.DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool);begin // Call assigned event if Assigned(FBeforeNavigate2) then FBeforeNavigate2(Self, pDisp, URL, Flags, TargetFrameName, PostData, Headers, Cancel);end;procedure TIEEvents.DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool);var pvDisp: IDispatch;begin // Call assigned event if Assigned(FNewWindow2) then begin if Assigned(ppDisp) then pvDisp := ppDisp else pvDisp := nil; FNewWindow2(Self, pvDisp, Cancel); ppDisp := pvDisp; end;end;procedure TIEEvents.DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant);begin // Call assigned event if Assigned(FNavigateComplete2) then FNavigateComplete2(Self, pDisp, URL);end;procedure TIEEvents.DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant);begin // Call assigned event if Assigned(FDocumentComplete) then FDocumentComplete(Self, pDisp, URL);end;procedure TIEEvents.DoOnQuit;begin // Call assigned event if Assigned(FOnQuit) then FOnQuit(Self);end;procedure TIEEvents.DoOnVisible(Visible: WordBool);begin // Call assigned event if Assigned(FOnVisible) then FOnVisible(Self, Visible);end;procedure TIEEvents.DoOnToolBar(ToolBar: WordBool);begin // Call assigned event if Assigned(FOnToolBar) then FOnToolBar(Self, ToolBar);end;procedure TIEEvents.DoOnMenuBar(MenuBar: WordBool);begin // Call assigned event if Assigned(FOnMenuBar) then FOnMenuBar(Self, MenuBar);end;procedure TIEEvents.DoOnStatusBar(StatusBar: WordBool);begin // Call assigned event if Assigned(FOnStatusBar) then FOnStatusBar(Self, StatusBar);end;procedure TIEEvents.DoOnFullScreen(FullScreen: WordBool);begin // Call assigned event if Assigned(FOnFullScreen) then FOnFullScreen(Self, FullScreen);end;procedure TIEEvents.DoOnTheaterMode(TheaterMode: WordBool);begin // Call assigned event if Assigned(FOnTheaterMode) then FOnTheaterMode(Self, TheaterMode);end;procedure Register;begin // Register the component on the Internet tab of the IDE RegisterComponents('Internet', [TIEEvents]);end;end. --- Project source ----//Notes: Add a button and the IEEvents component to Form1. The button1 click event // shows how the IE enumeration is achieved, and shows how the binding is done:unit Unit1;interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, IEEvents, StdCtrls, ActiveX, SHDocVw;type TForm1 = class(TForm) IEEvents1: TIEEvents; Button1: TButton; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure IEEvents1Quit(Sender: TObject); procedure IEEvents1DownloadBegin(Sender: TObject); procedure IEEvents1DownloadComplete(Sender: TObject); procedure Button1Click(Sender: TObject); procedure IEEvents1ProgressChange(Sender: TObject; Progress, ProgressMax: Integer); private { Private declarations } FTimeList: TList; public { Public declarations } end;var Form1: TForm1;implementation{$R *.dfm}procedure TForm1.Button1Click(Sender: TObject);var pvShell: IShellWindows; pvWeb2: IWebBrowser2; ovIE: OleVariant; dwCount: Integer;begin // Create the shell windows interface pvShell := CoShellWindows.Create; // Walk the internet explorer windows for dwCount := 0 to Pred(pvShell.Count) do begin // Get the interface ovIE := pvShell.Item(dwCount); // At this point you can evaluate the interface (LocationUrl, etc) // to decide if this is the one you want to connect to. For demo purposes, // the code will bind to the first one ShowMessage(ovIE.LocationURL); // QI for the IWebBrowser2 if (IDispatch(ovIE).QueryInterface(IWebBrowser2, pvWeb2) = S_OK) then begin IEEvents1.ConnectTo(pvWeb2); // Release the interface pvWeb2 := nil; end; // Clear the variant ovIE := Unassigned; // Break if we connected if IEEvents1.Connected then break; end; // Release the shell windows interface pvShell := nil;end;procedure TForm1.FormCreate(Sender: TObject);begin // Create the time list FTimeList := TList.Create;end;procedure TForm1.FormDestroy(Sender: TObject);begin // Free the time list FTimeList.Free;end;procedure TForm1.IEEvents1DownloadBegin(Sender: TObject);begin // Add the current time to the list FTimeList.Add(Pointer(GetTickCount));end;procedure TForm1.IEEvents1DownloadComplete(Sender: TObject);var dwTime: LongWord;begin // Pull the top item off the list (make sure there is one) if (FTimeList.Count > 0) then begin dwTime := LongWord(FTimeList[Pred(FTimeList.Count)]); FTimeList.Delete(Pred(FTimeList.Count)); // Now calculate total based on current time dwTime := GetTickCount - dwTime; // Display a message showing total download time ShowMessage(Format('Download time for "%s" was %d ms', [IEEvents1.WebObj.LocationURL, dwTime])); end;end;procedure TForm1.IEEvents1Quit(Sender: TObject);begin ShowMessage('About to disconnect');end;procedure TForm1.IEEvents1ProgressChange(Sender: TObject; Progress, ProgressMax: Integer);begin Caption := IntToStr(Progress);end;end.
0 0
- Delphi 通过IConnectionPointContainer响应COM事件的例子，Internet Explorer 事件响应
- DELPHI如何响应事件
- Internet Explorer 编程简述（十）响应来自HTML Element的事件通知——几个好用的类
- Internet Explorer 编程简述（十）响应来自HTML Element的事件通知——几个好用的类
- Internet Explorer 编程简述（十）响应来自HTML Element的事件通知——几个好用的类
- 如何用Delphi调用由VC开发的ATL/COM服务，并响应其事件
- 响应按钮的事件
- DataTable的事件响应
- 响应按钮的事件
- ExpandableListView 的事件响应
- 鼠标事件的响应
- 事件响应
- 事件响应
- VBS和页面中响应COM的事件
- Delphi在Image中响应键盘事件
- delphi 让ScrollBox响应鼠标滚轮事件
- delphi 让ScrollBox响应鼠标滚轮事件
- delphi 让ScrollBox响应鼠标滚轮事件
- 需要阅读的经典管理书籍
- 经典排序之堆排序
- C++内存管理
- poj1269-Intersecting Lines（求线段交点）
- 树状数组专题
- Delphi 通过IConnectionPointContainer响应COM事件的例子，Internet Explorer 事件响应
- 程序运行过程中的各个寄存器！
- Eclipse 中 显示代码的行号
- 最新的Android SDK安装攻略(动作要快,来晚就失效了)
- 武道释义 · 零散
- C语言 stringcpy,stringcat,stringcmp实现
- Makefile
- 成佩涛-项目管理成功之六大因素
- python 下载整个网站
