Delphi不注册COM直接使用ActiveX控件并绑定事件
文笔不行,直接上源码:
主窗口:
unit Unit1; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, Winapi.ActiveX , System.Win.ComObj, EventSink; type TForm1 = class(TForm) pnlCom: TPanel; Panel2: TPanel; Panel3: TPanel; btnGo: TButton; edt1: TEdit; LblStatus: TLabel; procedure FormCreate(Sender: TObject); procedure btnGoClick(Sender: TObject); private { Private declarations } EventSink: TEventSink; ActiveXCon: Variant; function InitAtl: Boolean; procedure EventSinkInvoke(Sender: TObject; DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer); public { Public declarations } end; var Form1: TForm1; const CLASS_MsRdpClient: TGUID = '{7CACBD7B-0D99-468F-AC33-22E495C0AFE5}';//'{791FA017-2DE3-492E-ACC5-53C67A2B94D0}'; type PIUnknown=^IUnknown; TAtlAxAttachControl = function(Control:IUnknown; hwind:hwnd;ppUnkContainer:PIUnknown): HRESULT; stdcall; //--此处参考mstscax.dll的接口文件，如果没有，在 Component->Import Component->Import a Type Library //--导入：Microsoft Terminal Services Active Client 1.0 Type Library 1.0 IMsTscAxEvents = dispinterface ['{336D5562-EFA8-482E-8CB3-C5C0FC7A7DB6}'] { procedure OnConnecting; dispid 1; procedure OnConnected; dispid 2; procedure OnLoginComplete; dispid 3; procedure OnDisconnected(discReason: Integer); dispid 4; procedure OnEnterFullScreenMode; dispid 5; procedure OnLeaveFullScreenMode; dispid 6; procedure OnChannelReceivedData(const chanName: WideString; const data: WideString); dispid 7; procedure OnRequestGoFullScreen; dispid 8; procedure OnRequestLeaveFullScreen; dispid 9; procedure OnFatalError(errorCode: Integer); dispid 10; procedure OnWarning(warningCode: Integer); dispid 11; procedure OnRemoteDesktopSizeChange(width: Integer; height: Integer); dispid 12; procedure OnIdleTimeoutNotification; dispid 13; procedure OnRequestContainerMinimize; dispid 14; function OnConfirmClose: WordBool; dispid 15; function OnReceivedTSPublicKey(const publicKey: WideString): WordBool; dispid 16; function OnAutoReconnecting(disconnectReason: Integer; attemptCount: Integer): AutoReconnectContinueState; dispid 17; procedure OnAuthenticationWarningDisplayed; dispid 18; procedure OnAuthenticationWarningDismissed; dispid 19; } end; implementation {$R *.dfm} { TForm1 } function CreateComObjectFromDll(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) then begin hr := DllGetClassObject(CLSID, IClassFactory, Factory); if hr = S_OK then try hr := Factory.CreateInstance(nil, IUnknown, Result); if hr <> S_OK then begin ShowMessage('Error'); end; except ShowMessage(IntToStr(GetLastError)); end; end; end; procedure TForm1.btnGoClick(Sender: TObject); begin ActiveXCon.Navigate(edt1.Text); end; procedure TForm1.EventSinkInvoke(Sender: TObject; DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer); begin <p> { 这里需要注明Params这个参数, 包含了事件的参数 如： Params.rgvarg[0] 代表第一个参数 Params.rgvarg[1] 代表第二个参数 ...... Params.rgvarg[65535] 代表第65535个参数 最多65535个参数 具体可以参考 tagDISPPARAMS 的定义</p><p> 这里只列出了怎么扑获相关事件，具体功能具体实现 }</p> case dispid of $00000001: LblStatus.Caption := '正在连接'; $00000002: LblStatus.Caption := '连接成功'; $00000003: LblStatus.Caption := '登陆成功'; $00000004: LblStatus.Caption := '断开连接'; $00000005: LblStatus.Caption := '进入全屏模式'; $00000006: LblStatus.Caption := '离开全屏模式'; $00000007: LblStatus.Caption := '通道接收数据'; $00000008: LblStatus.Caption := 'OnRequestGoFullScreen'; $00000009: LblStatus.Caption := 'OnRequestLeaveFullScreen'; $00000010: LblStatus.Caption := 'OnFatalError'; $00000011: LblStatus.Caption := 'OnWarning'; $00000012: LblStatus.Caption := 'OnRemoteDesktopSizeChange'; $00000013: LblStatus.Caption := 'OnIdleTimeoutNotification'; $00000014: LblStatus.Caption := 'OnRequestContainerMinimize'; $00000015: LblStatus.Caption := 'OnConfirmClose'; $00000016: LblStatus.Caption := 'OnReceivedTSPublicKey'; $00000017: LblStatus.Caption := 'OnAutoReconnecting'; $00000018: LblStatus.Caption := 'OnAuthenticationWarningDisplayed'; $00000019: LblStatus.Caption := '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 begin Exit(False); end; AtlAxAttachControl := TAtlAxAttachControl(GetProcAddress(hModule, 'AtlAxAttachControl')); EventSink := TEventSink.Create(Self); EventSink.OnInvoke := EventSinkInvoke; if not Assigned(AtlAxAttachControl) then Exit(False); try {--后期绑定} // ActiveXCon := CreateComObject(CLASS_MsRdpClient); //CreateOleObject('Shell.Explorer'); //CreateComObject(CLASS_MsRdpClient); {--前期绑定} hDll := LoadLibrary('mstscax.dll'); ActiveXCon := CreateComObjectFromDll(CLASS_MsRdpClient, hDll) as IDispatch; // if Assigned(ActiveXCon) then begin // // end; if VarIsNull(ActiveXCon) then begin Result := False; Exit; end; EventSink.Connect(ActiveXCon, IMsTscAxEvents); AtlAxAttachControl(ActiveXCon,pnlCom.Handle, nil); // ActiveXCon.GoHome; ActiveXCon.Server := '192.168.8.65'; ActiveXCon.UserName := 'Va_admin'; ActiveXCon.AdvancedSettings2.ClearTextPassword := 'Va5!1232'; ActiveXCon.Connect; Result := True; except Result := False; end; end; end.
事件单元:
unit EventSink; interface uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Winapi.ActiveX; type TInvokeEvent = procedure(Sender: TObject; DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; Params: TDispParams; VarResult, ExcepInfo, ArgErr: Pointer) of object; TAbstractEventSink = class(TObject, IUnknown, IDispatch) private FDispatch: IDispatch; FDispIntfIID: TGUID; FConnection: LongInt; FOwner: TComponent; protected { 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; public constructor Create(AOwner: TComponent); destructor Destroy; override; procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); procedure Disconnect; end; TEventSink = class(TComponent) private { Private declarations } FSink: TAbstractEventSink; FOnInvoke: TInvokeEvent; protected { Protected declarations } procedure DoInvoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer); virtual; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); published { Published declarations } property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke; end; implementation uses ComObj; procedure InterfaceConnect(const Source: IUnknown; const IID: TIID; const Sink: IUnknown; var Connection: LongInt); var CPC: IConnectionPointContainer; CP: IConnectionPoint; i: HRESULT; begin Connection := 0; if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then if Succeeded(CPC.FindConnectionPoint(IID, CP)) then i := CP.Advise(Sink, Connection); end; procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID; var Connection: LongInt); var CPC: IConnectionPointContainer; CP: IConnectionPoint; begin if Connection <> 0 then if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then if Succeeded(CPC.FindConnectionPoint(IID, CP)) then if Succeeded(CP.Unadvise(Connection)) then Connection := 0; end; { TAbstractEventSink } function TAbstractEventSink._AddRef: Integer; stdcall; begin Result := 2; end; function TAbstractEventSink._Release: Integer; stdcall; begin Result := 1; end; constructor TAbstractEventSink.Create(AOwner: TComponent); begin inherited Create; FOwner := AOwner; end; destructor TAbstractEventSink.Destroy; var p: Pointer; begin Disconnect; inherited Destroy; end; function TAbstractEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall; begin Result := E_NOTIMPL; end; function TAbstractEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo) : HRESULT; stdcall; begin Result := E_NOTIMPL; end; function TAbstractEventSink.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; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall; begin (FOwner as TEventSink).DoInvoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr); Result := S_OK; end; function TAbstractEventSink.QueryInterface(const IID: TGUID; out Obj) : HRESULT; stdcall; begin // We need to return the event interface when it's asked for Result := E_NOINTERFACE; if GetInterface(IID, Obj) then Result := S_OK; if IsEqualGUID(IID, FDispIntfIID) and GetInterface(IDispatch, Obj) then Result := S_OK; end; procedure TAbstractEventSink.Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); begin FDispIntfIID := AnAppDispIntfIID; FDispatch := AnAppDispatch; // Hook the sink up to the automation server InterfaceConnect(FDispatch, FDispIntfIID, Self, FConnection); end; procedure TAbstractEventSink.Disconnect; begin if Assigned(FDispatch) then begin // Unhook the sink from the automation server InterfaceDisconnect(FDispatch, FDispIntfIID, FConnection); FDispatch := nil; FConnection := 0; end; end; { TEventSink } procedure TEventSink.Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID); begin FSink.Connect(AnAppDispatch, AnAppDispIntfIID); end; constructor TEventSink.Create(AOwner: TComponent); begin inherited Create(AOwner); FSink := TAbstractEventSink.Create(Self); end; destructor TEventSink.Destroy; begin FSink.Free; inherited Destroy; end; procedure TEventSink.DoInvoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer); begin if Assigned(FOnInvoke) then FOnInvoke(Self, DispID, IID, LocaleID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr); end; end.
效果图:
