Delphi不注冊COM直接使用ActiveX控件并綁定事件

1、Delphi 不注冊 COM 直接使用 ActiveX 控件并綁定事件文筆不行 ,直接上源碼 :interface uses主窗口 : delphi view plaincopyunit Unit1;Winapi.Windows, Winapi.Messages, System.SysUtils,System.Variants, System.Classes, Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, System.Win.ComObj,Vcl.StdCtrls, Winapi.ActiveXEventSi

2、nk; typeTForm1 = class(TForm)pnlCom: TPanel;Panel2: TPanel;Panel3: TPanel;btnGo: TButton;edt1: TEdit;LblStatus: TLabel;procedure FormCreate(Sender: TObject);procedurebtnGoClick(Sender: TObject);private Privatedeclarations EventSink: TEventSink;ActiveXCon: Variant;function InitAtl: Boolean;procedure

3、EventSinkInvoke(Sender: TObject; DispID: Integer;const IID: TGUID; LocaleID: Integer; Flags: Word;Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: var Form1: TForm1; const CLASS_MsRdpClient:Pointer); public Public declarations end;TGUID ='7CACBD7B-0D99-468F-AC33-22E495C0AFE5'/'791FA0

4、type17-2DE3-492E-ACC5-53C67A2B94D0'PIUnknown=A|Unknown;TAtlAxAttachControl =function(Control:IUnknown;hwind:hwnd;ppUnkContainer:PIUnknown): HRESULT; stdcall;/- 此處參考 mstscax.dll 的接口文件，如果沒有，在Component->Import Component->Import a Type Library/-導入： Microsoft Terminal Services Active Cl

5、ient 1.0 TypeLibrary 1.0 IMsTscAxEvents = dispinterface'336D5562-EFA8-482E-8CB3-C5C0FC7A7DB6'procedure OnConnecting; dispid 1;procedureOnConnected; dispid 2;procedure OnLoginComplete;dispid 3;procedure OnDisconnected(discReason: Integer);dispid 4;procedure OnEnterFullScreenMode; dispid 5;pro

6、cedure OnLeaveFullScreenMode; dispid 6;procedureOnChannelReceivedData(const chanName: WideString; constdata: WideString); dispid 7;procedureOnRequestGoFullScreen; dispid 8;procedureOnRequestLeaveFullScreen; dispid 9;procedureOnFatalError(errorCode: Integer); dispid 10;procedureOnWarning(warningCode:

7、 Integer); dispid 11;procedureOnRemoteDesktopSizeChange(width: Integer; height: Integer);dispid 12;procedure OnIdleTimeoutNotification; dispid 13;functionprocedure OnRequestContainerMinimize; dispid 14;function OnConfirmClose: WordBool; dispid 15;OnReceivedTSPublicKey(const publicKey: WideString):Wo

8、rdBool; dispid 16;functionOnAutoReconnecting(disconnectReason: Integer; attemptCount:Integer): AutoReconnectContinueState; dispid 17;procedure OnAuthenticationWarningDisplayed; dispid 18;procedure OnAuthenticationWarningDismissed; dispid19; end; implementation $R *.dfm TForm1 function CreateComObjec

9、tFromDll(CLSID:TGUID; DllHandle: THandle): IUnknown; var Factory:IClassFactory; DllGetClassObject: function(const CLSID,IID: TGUID; var Obj): HResult; stdcall;hr: HRESULT;begin DllGetClassObject := GetProcAddress(DllHandle,'DllGetClassObject'); if Assigned(DllGetClassObject) thenbeginhr := D

10、llGetClassObject(CLSID, IClassFactory,Factory);if hr = S_OK thentryhr :=if hrFactory.CreateInstance(nil, IUnknown, Result);<> S_OK then beginShowMessage('Error');end;exceptend; end;ShowMessage(IntToStr(GetLastError);$00000013:end; procedure TForm1.btnGoClick(Sender: TObject);be

11、gin ActiveXCon.Navigate(edt1.Text); end;procedure TForm1.EventSinkInvoke(Sender: TObject; DispID:Integer; const IID: TGUID; LocaleID: Integer; Flags: Word;這里需要注明 Params 這Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr:Pointer); begin <p> 個參數(shù) , 包含了事件的參數(shù)如：Params.rgvarg0代表第一個參數(shù)Params.

12、rgvarg1代表第二個參Params.rgvarg65535代表第 65535 個參數(shù)最多 65535 個參數(shù)具體可以參考tagDISPPARAMS 的定義 </p><p>這里只列出了怎么撲獲相關事件，具體功能具體實現(xiàn)</p> case dispid of$00000001: LblStatus.Caption := ' 正在連接 '$00000002:LblStatus.Caption := '連接成功 '$00000003:LblStatus.Caption := '

13、; 登陸成功 '$00000004:LblStatus.Caption := ' 斷開連接 '$00000005:LblStatus.Caption := ' 進入全屏模式 '$00000006:LblStatus.Caption := ' 離開全屏模式 '$00000007:LblStatus.Caption := ' 通道接收數(shù)據(jù) '$00000008:LblStatus.Caption := 'OnRequestGoFullScreen'$00000009: LblStatus.Caption :=

14、'OnRequestLeaveFullScreen'$00000010: LblStatus.Caption := 'OnFatalError'$00000011: LblStatus.Caption := 'OnWarning'$00000012: LblStatus.Caption :='OnRemoteDesktopSizeChange'LblStatus.Caption := 'OnIdleTimeoutNotification'$00000014: LblStatus.Caption :='OnR

15、equestContainerMinimize'$00000015:LblStatus.Caption := 'OnConfirmClose'$00000016:LblStatus.Caption := 'OnReceivedTSPublicKey'$00000017: LblStatus.Caption := 'OnAutoReconnecting'$00000018: LblStatus.Caption :='OnAuthenticationWarningDisplayed'$00000019:LblStatus.Ca

16、ption := 'OnAuthenticationWarningDismissed'end end; procedure TForm1.FormCreate(Sender: TObject);begin InitAtl; end; function TForm1.InitAtl: Boolean;var hModule, hDll: THandle;AtlAxAttachControl:TAtlAxAttachControl;begin hModule :=LoadLibrary('atl.dll');if hModule < 32 then b

17、eginExit(False); end;AtlAxAttachControl :=TAtlAxAttachControl(GetProcAddress(hModule,'AtlAxAttachControl');EventSink :=TEventSink.Create(Self); EventSink.OnInvoke :=EventSinkInvoke; if not Assigned(AtlAxAttachControl)thenExit(False); try- 后期綁定 /ActiveXCon := CreateComObject(CLASS_MsRdpClient

18、);/CreateOleObject('Shell.Explorer');/CreateComObject(CLASS_MsRdpClient);- 前期綁定 hDll := LoadLibrary('mstscax.dll');ActiveXCon :=CreateComObjectFromDll(CLASS_MsRdpClient, hDll) asIDispatch; / if Assigned(ActiveXCon) then begin / /end;if VarIsNull(ActiveXCon) then beginResult := False;

19、Exit;end;/EventSink.Connect(ActiveXCon, IMsTscAxEvents);AtlAxAttachControl(ActiveXCon,pnlCom.Handle, nil);ActiveXCon.GoHome;ActiveXCon.Server :='5'ActiveXCon.UserName := 'Va_admin'ActiveXCon.AdvancedSettings2.ClearTextPassword :='Va5!1232'ActiveXCon.Connect;Result

20、:= True;exceptResult := False; end;end; erface uses事件單元 : delphi view plaincopyunit EventSink;Winapi.Windows, Winapi.Messages, System.SysUtils,System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms,type TInvokeEventVcl.Dialogs, Winapi.ActiveX;= procedure(Sender: TObject; DispID: Integer; const

21、 IID:TGUID;LocaleID: Integer; Flags: Word; Params:TDispParams;VarResult, ExcepInfo, ArgErr: Pointer) ofobject;TAbstractEventSink = class(TObject, IUnknown,IDispatch) privateFDispatch: IDispatch;FDispIntfIID: TGUID;FConnection: LongInt;FOwner: TComponent;protected IUnknown function QueryInterface(con

22、st 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;functionGetIDsOfNames(const IID: TGU

23、ID; Names: Pointer;stdcall;NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;function Invoke(DispID: Integer; const IID:TGUID; LocaleID: Integer;Flags: Word; var Params;VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;stdcall; publicconstructor Create(AOwner:TComponent);destructor Destroy; ove

24、rride;procedure Connect(AnAppDispatch: IDispatch; constAnAppDispIntfIID: TGUID);procedure Disconnect;end;TEventSink = class(TComponent) private Private declarations FOnInvoke: TInvokeEvent;protected Protecteddeclarations procedure DoInvoke(DispID: Integer;const IID: TGUID; LocaleID: Integer;Flags: W

25、ord;var Params; VarResult, ExcepInfo, ArgErr: Pointer); virtual;public Public declarations constructorCreate(AOwner: TComponent); override;destructorDestroy; override;procedure Connect(AnAppDispatch:IDispatch; const AnAppDispIntfIID: TGUID);published Published declarations property OnInvoke:TInvokeE

26、vent read FOnInvoke write FOnInvoke;end;implementation uses ComObj; procedureInterfaceConnect(const Source: IUnknown; const IID: TIID;const Sink: IUnknown; var Connection: LongInt); varCPC: IConnectionPointContainer;CP: IConnectionPoint;i: HRESULT; begin Connection := 0; ifSucceeded(Source.QueryInte

27、rface(IConnectionPointContainer,CPC) thenif Succeeded(CPC.FindConnectionPoint(IID,CP) theni := CP.Advise(Sink, Connection); end;procedure InterfaceDisconnect(const Source: IUnknown; constIID: TIID;var Connection: LongInt); var CPC:FSink: TAbstractEventSink;ifIConnectionPointContainer; CP: IConnectio

28、nPoint; begin if Connection <> 0 thenSucceeded(Source.QueryInterface(IConnectionPointContainer,CPC) thenifSucceeded(CPC.FindConnectionPoint(IID, CP) thenif Succeeded(CP.Unadvise(Connection) thenConnection := 0; end; TAbstractEventSink functionTAbstractEventSink._AddRef: Integer; stdcal

29、l; beginResult := 2; end; function TAbstractEventSink._Release:Integer; stdcall; begin Result := 1; end;constructorTAbstractEventSink.Create(AOwner: TComponent);begininherited Create; FOwner := AOwner; end;destructorTAbstractEventSink.Destroy; var p: Pointer;beginDisconnect;inherited Destroy; end; f

30、unctionTAbstractEventSink.GetIDsOfNames(const IID: TGUID;Names: Pointer; NameCount, LocaleID: Integer; DispIDs:Pointer): HRESULT; stdcall; begin Result :=E_NOTIMPL; end; functionTAbstractEventSink.GetTypeInfo(Index, LocaleID: Integer; outTypeInfo) : HRESULT; stdcall; begin Result :=E_NOTIMPL; end; f

31、unctionTAbstractEventSink.GetTypeInfoCount(out Count: Integer)HRESULT; stdcall; begin Count := 0; Result := S_OK;end; function TAbstractEventSink.Invoke(DispID: Integer;const IID: TGUID;LocaleID: Integer; Flags: Word; varParams; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;stdcall; begin (FOwner

32、as TEventSink).DoInvoke(DispID,IID, LocaleID, Flags, Params,VarResult, ExcepInfo,ArgErr); Result := S_OK; end; functionTAbstractEventSink.QueryInterface(const IID: TGUID; outObj) : HRESULT; stdcall; begin / We need to returnthe event interface when it's asked for Result :=E_NOINTERFACE;if GetInterface(IID, Obj) thenResult := S_OK; if IsEqualGUID(IID, FDispIntfIID) andGetInterface(IDispatch, Obj) thenResult := S_OK; end;procedure TAbstractEventSink.Connect(AnApp