对于使用CreateOleObject创建的对象，怎样定义它的fire 事件。

[yangzi]

兄弟我一直写vc的程序，现在要修改别人的delphi程序。
只好试着写了

我的问题是，一个nt service的守护程序，我使用了一个对象，它有event，可以在接收到请求时触发，但我不知道代码该怎样写，谢谢各位了

[yangzi]

老大们帮忙啊。兄弟快疯了

[Linux2001]

你也太夸张了吧，这么麻烦的问题还要让别人给你写代码吗？我想代码量可能很多啊

[waxi]

把分都加给我,我就写,可以吗?

[yangzi]

可能要用到sink,兄弟熟吗？
分不是问题，我还有7000多分。

[westfly]

需要实现一个IDispatch接口作事件接收器(EventSink)，
在接口里的invoke里实现事件代码，
创建ole对象后，
用InterfaceConnect将该接口连接上ole对象，
这样便可处理ole对象触发的事件了，
ole对象销毁前需要用InterfaceDisconnect断开之

[westfly]

具体实现方法可参考d5开发人员指南上的例子,
不过它给出的代码量有点大，
这里给出一个较简单的实现方法,

第一步：创建一个EventSink(整个过程你只需写几行代码)

File -> New -> ActiveX -> Automation object -> (Instancing Internal),
delphi为为你自动生成一个内部的自动化对象,
我们将用它作为EventSink,
把目标ole对象的事件定义加入它的方法列表，
(如：假定事件目标ole对象为某个网页的一个按钮的onclick事件，则往你的EventSink里加上一个同名的方法onclick，参数也要一致)
此时delphi会自动为你生成该事件的代码，不过是空的，往里面填上你的功能代码即可。
显然，我们需要实现对事件接口的支持，
故需重载ObjQueryInterface方法(被QueryInterface所调用)，
当传入iid为ole事件接口的iid时返回S_OK即可，
以下为EventSink相应代码:

function TEventSink.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
begin
if IsEqualGUID(IID, Form1.OleEventIID) and GetInterface(IDispatch, Obj) then
Result := S_OK
else
Result := inherited ObjQueryInterface(IID, Obj);
end;

procedure TEventSink.OnClear;
begin
Form1.Memo1.Clear;
end;

procedure TEventSink.OnTextChanged(const NewText: WideString);
begin
Form1.Memo1.Text := NewText;
end;


第二步：绑定该EventSink到ole对象上

在ole对象创建之后(假定在FormCreate中创建)
procedure TForm1.FormCreate(Sender: TObject);
begin
FServer := CreateOleObject('MyTyplib.MyObj')
FEvent := TEventSink.Create;
TheOleEventIID := ?;
//TheOleEventIID: TGUID 为ole对象事件接口的iid, 可查其类型库得到
InterfaceConnect(FServer, OleEventIID, FEvent, FConnection);
//if FConnection > 0 then ShowMessage('连接成功。');
end;

//ok, 大功告成。
//如有疑问，可向我要源代码例子

[yangzi]

好的，谢谢。

[yangzi]

兄弟，我在国外，手头没有书，如果方便的话，希望能把例子发给我。[e-mail]，或者[e-mail]

[westfly]

我给你的[e-mail]发了一份例程，
演示了动态绑定web页面中按钮点击事件的例子

[westfly]

顺便把主要代码公开出来让其他人参考:

[westfly]

//这是类型库自动生成的代码，我把delphi自动生成的注释删掉了，方便阅读
//请注意，这里onclick指定的dispid跟HTMLButtonElementEvents2的IID一致。

unit OleEventDemo_TLB;
{$TYPEDADDRESS OFF}
interface
uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL;
const
// TypeLibrary Major and minor versions
ClientDemo2MajorVersion = 1;
ClientDemo2MinorVersion = 0;

LIBID_ClientDemo2: TGUID = '{8BE97D79-E940-458D-9C82-FCA7E0D4ED61}';

IID_IEventSink: TGUID = '{D7EB2580-1D81-4049-A211-B7438DE62D56}';
CLASS_EventSink: TGUID = '{C4BE29E4-7139-4B3C-9AA0-4C476E293EAA}';
type
IEventSink = interface;
IEventSinkDisp = dispinterface;

EventSink = IEventSink;
IEventSink = interface(IDispatch)
['{D7EB2580-1D81-4049-A211-B7438DE62D56}']
function onclick(const dispSource: IDispatch): WordBool; safecall;
end;

IEventSinkDisp = dispinterface
['{D7EB2580-1D81-4049-A211-B7438DE62D56}']
function onclick(const dispSource: IDispatch): WordBool; dispid -600;
end;

CoEventSink = class
class function Create: IEventSink;
class function CreateRemote(const MachineName: string): IEventSink;
end;

implementation

uses ComObj;

class function CoEventSink.Create: IEventSink;
begin
Result := CreateComObject(CLASS_EventSink) as IEventSink;
end;

class function CoEventSink.CreateRemote(const MachineName: string): IEventSink;
begin
Result := CreateRemoteComObject(MachineName, CLASS_EventSink) as IEventSink;
end;

end.

[yangzi]

OK,多谢了，好人好运

[westfly]

//接下来是接口的实现代码，
//这个是内部接口，无需注册
//注意其中的onclick代码，dispSource即网页中的event对象

unit u_EventSink;

interface

uses
ComObj, ActiveX, OleEventDemo_TLB, StdVcl, SysUtils;

type
TEventSink = class(TAutoObject, IEventSink)
protected
function onclick(const dispSource: IDispatch): WordBool; safecall;
{ Protected declarations }
public
function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
end;

implementation
uses ComServ, u_Main, Windows;

function TEventSink.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
begin
if IsEqualGUID(IID, Form1.FEventIID) and GetInterface(IDispatch, Obj) then
Result := S_OK
else
Result := inherited ObjQueryInterface(IID, Obj);
end;

function TEventSink.onclick(const dispSource: IDispatch): WordBool;
begin
OleVariant(dispSource).srcElement.style.backgroundColor := '#' + IntToHex(RGB(Random(256), Random(256), Random(256)), 6);
Result := True;
end;

initialization
TAutoObjectFactory.Create(ComServer, TEventSink, Class_EventSink,
ciInternal, tmApartment);
end.

[westfly]

//主程序：
unit u_Main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ToolWin, ComCtrls, OleEventDemo_TLB, ActiveX,
OleCtrls, SHDocVw, MSHtml;

type
TForm1 = class(TForm)
ToolBar1: TToolBar;
wb: TWebBrowser;
Button1: TButton;
Button2: TButton;
Button3: TButton;
StatusBar1: TStatusBar;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
procedure WriteHtml(const AHtml: String);
public
{ Public declarations }
FServer: IHTMLButtonElement;
FEventIID: TGUID;
FEvent: IEventSink;
FConnection: Integer;
end;

var
Form1: TForm1;

implementation
uses ComObj, u_EventSink;

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
wb.Navigate('about:blank');
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
WriteHtml('<html><body><button id=btn>测试按钮</button><br/>本页面中按钮响应代码来自delphi</body></html>');
end;

procedure TForm1.Button2Click(Sender: TObject);
var doc: IHTMLDocument2; btn: IHTMLButtonElement;
begin
doc := wb.Document as IHTMLDocument2;
btn := doc.all.item('btn', EmptyParam) as IHTMLButtonElement;
FServer := btn;
FEvent := TEventSink.Create;
FEventIID := HTMLButtonElementEvents2;
FConnection := 0;
InterfaceConnect(FServer, FEventIID, FEvent, FConnection);
StatusBar1.SimpleText := IntToStr(FConnection);
end;

procedure TForm1.WriteHtml(const AHtml: String);
var
Stream: ActiveX.IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(wb.Document) then Exit;
hHTMLText := GlobalAlloc(GPTR, Length(AHtml) + 1);
if 0 = hHTMLText then RaiseLastWin32Error;
CopyMemory(Pointer(hHTMLText), PChar(AHtml), Length(AHtml));
OleCheck(CreateStreamOnHGlobal(hHTMLText, True, Stream));
try
OleCheck(wb.Document.QueryInterface(IPersistStreamInit, psi));
try
OleCheck(psi.InitNew);
OleCheck(psi.Load(Stream));
finally
psi := nil;
end;
finally
Stream := nil;
end;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
FServer.value := '已取消。';
ComObj.InterfaceDisconnect(FServer, FEventIID, FConnection);
StatusBar1.SimpleText := IntToStr(FConnection);
FEvent := nil;
FServer := nil;
end;

end.

[halfdream]

收藏