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>  {

&nbsp;&nbsp;&nbsp; 这里需要注明Params这个参数, 包含了事件的参数

&nbsp;&nbsp;&nbsp; 如：

&nbsp;&nbsp;&nbsp; Params.rgvarg[0] 代表第一个参数

&nbsp;&nbsp;&nbsp; Params.rgvarg[1] 代表第二个参数

&nbsp;&nbsp;&nbsp; ......

&nbsp;&nbsp;&nbsp; Params.rgvarg[65535] 代表第65535个参数

&nbsp;&nbsp;&nbsp; 最多65535个参数

&nbsp;&nbsp;&nbsp; 具体可以参考 tagDISPPARAMS 的定义</p><p>&nbsp;&nbsp;&nbsp; 这里只列出了怎么扑获相关事件，具体功能具体实现

&nbsp; }</p>  case dispid of

    $: LblStatus.Caption := '正在连接';

    $: LblStatus.Caption := '连接成功';

    $: LblStatus.Caption := '登陆成功';

    $: LblStatus.Caption := '断开连接';

    $: LblStatus.Caption := '进入全屏模式';

    $: LblStatus.Caption := '离开全屏模式';

    $: LblStatus.Caption := '通道接收数据';

    $: LblStatus.Caption := 'OnRequestGoFullScreen';

    $: LblStatus.Caption := 'OnRequestLeaveFullScreen';

    $: LblStatus.Caption := 'OnFatalError';

    $: LblStatus.Caption := 'OnWarning';

    $: LblStatus.Caption := 'OnRemoteDesktopSizeChange';

    $: LblStatus.Caption := 'OnIdleTimeoutNotification';

    $: LblStatus.Caption := 'OnRequestContainerMinimize';

    $: LblStatus.Caption := 'OnConfirmClose';

    $: LblStatus.Caption := 'OnReceivedTSPublicKey';

    $: LblStatus.Caption := 'OnAutoReconnecting';

    $: LblStatus.Caption := 'OnAuthenticationWarningDisplayed';

    $: 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 <  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 := ;

  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 <>  then

    if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then

      if Succeeded(CPC.FindConnectionPoint(IID, CP)) then

        if Succeeded(CP.Unadvise(Connection)) then

          Connection := ;

end;

{ TAbstractEventSink }

function TAbstractEventSink._AddRef: Integer; stdcall;

begin

  Result := ;

end;

function TAbstractEventSink._Release: Integer; stdcall;

begin

  Result := ;

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 := ;

  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 := ;

  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.

效果图:

Delphi不注册COM直接使用ActiveX控件并绑定事件的更多相关文章

【VS开发】动态添加的ActiveX控件如何响应事件
http://blog.csdn.net/xiaoqiqixiao/article/details/574542 今天在csdn上看到一朋友问如何响应动态添加的控件的事件,搜索资料,发现对于一般的应用 ...
Wix中注册c#开发的Activex控件
一.使用regasm.exe将DLL提取出TLB文件 regasm.exe "Tools.HMIBrowserDetector.dll" /tlb 二.使用wix的heat.exe ...
ActiveX控件的Events事件
http://labview360.com/article/info.asp?TID=10152&FID=165 Active X函式库对使用LabVIEW作为开发环境的开发人员来说,如果能 ...
Delphi 编写ActiveX控件（OCX控件）的知识和样例（有详细步骤）
一.ActiveX应用情况简介: ActiveX控件也就是一般所说的OCX控件,它是 ActiveX技术的一部分.ActiveX是微软公司推出的基于组件对象模型COM的技术,包括对Windows 32 ...
【VS开发】windows注册ActiveX控件
ActiveX控件是一个动态链接库,是作为基于COM服务器进行操作的,并且可以嵌入在包容器宿主应用程序中,ActiveX控件的前身就是OLE控件.由于ActiveX控件与开发平台无关,因此,在一种编程 ...
ActiveX控件的基本操作方法以及如何在VS2010下使用控件
在此,小编就介绍下ActiveX控件的基本操作方法以及如何在VS2010下使用控件,我们以一个程序为例, (1) 打开VS2010编译器(右键以管理员身份运行,因为ActiveX需要注册), ...
ActiveX控件
什么是ActiveX控件:一个进程内服务器,支持多种的COM接口.(可以理解为,一个COM接口是一个纯抽象基类,你实现了它,并且它支持自注册,就是一个ActiveX控件了)可以把ActiveX控件看做 ...
建立对ActiveX控件的了解
本文来自百度百科:ActiveX控件 ActiveX是Microsoft对于一系列策略性面向对象程序技术和工具的称呼,其中主要的技术是组件对象模型(COM).在有目录和其它支持的网络中,COM变成 ...
开发ActiveX控件调用另一个ActiveX系列0——身份证识别仪驱动的问题
程序员要从0下表开始,这篇是介绍这个系列的背景的,没有兴趣的人可以直接跳过. 为什么要开发ActiveX控件由于工作需要,我们开发了一个网站,使用了一款身份证识别仪的网页ActiveX(OCX)插件 ...

随机推荐

[学习笔记]Javascript的包装对象
例子1: var s="test"; s.len = 4; var t = s.len // t is undefined 原因是s是字符串,第二行代码,实际上是创建一个临时字符串 ...
js的闭包的一个示例说明
js中某个函数的内部函数在该函数执行结束后仍然可以访问这个函数中定义的变量,这称为闭包(Closure) 复制代码代码如下: function outside() { var myVar = 1; ...
（六）cxf处理一些Map等复杂类型
前面讲的一些都是简单类型,cxf都支持.但是有些复杂类型,cxf是不支持,比如常用的Map类型: 下面我们在前面的实例基础上在加一个方法,比如我们现在有个需求,获取所有用用户以及对应的每个用户所有角色 ...
python 全栈开发，Day92(编程式的导航,vue页面布局,marked包的使用)
昨日内容回顾 1. 组件间的传值 1. bus --> 空Vue对象通过向bus对象抛出自定义事件的方式在组件间传递信息 2. 注意事项: 1. bus.$on()应该在组件mounted(挂 ...
字节、字、bit、byte的关系【转】
字 word 字节 byte 位 bit 字长是指字的长度 1字=2字节(1 word = 2 byte) 1字节=8位(1 byte = 8bit) 一个字的字长为16 一个字节的字长是8 bps ...
#ECMASCRIPT6笔记
ECMASCRIPT6笔记来源于http://es6.ruanyifeng.com/#docs/proxy 是我在阅读时做下的笔记,方便以后查阅 Symbol ES5 的对象属性名都是字符串,这容易 ...
攻击图生成工具mulval的安装和配置
https://doc.mbalib.com/view/8620168b35e50fbe9b005fee33c192ad.html http://www.bingbig.com/227.html
UOJ Round #1 题解
题解: 质量不错的一套题目啊..(题解也很不错啊) t1: 首先暴力显然有20分,把ai相同的缩在一起就有40分了然后会发现由于原来的式子有个%很不方便处理 so计数题嘛考虑一下容斥最终步数=初 ...
BZOJ1303 [CQOI2009]中位数图其他
欢迎访问~原文出处——博客园-zhouzhendong 去博客园看该题解题目传送门 - BZOJ1303 题意概括给出1~n的一个排列,统计该排列有多少个长度为奇数的连续子序列的中位数是b.中位数 ...
【Java】剑指offer(31) 栈的压入、弹出序列
本文参考自<剑指offer>一书,代码采用Java语言. 更多:<剑指Offer>Java实现合集题目输入两个整数序列,第一个序列表示栈的压入顺序,请判断第二个序列是否 ...

Delphi不注册COM直接使用ActiveX控件并绑定事件

Delphi不注册COM直接使用ActiveX控件并绑定事件的更多相关文章

随机推荐

热门专题