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)插件 ...

随机推荐

Expm 2_1 k-路合并操作问题
假定有k个有序数组,每个数组中含有n个元素,您的任务是将它们合并为单独的一个有序数组,该数组共有kn个元素.设计和实现一个有效的分治算法解决k-路合并操作问题,并分析时间复杂度.
转：前端页面a标签嵌套a标签效果的两种解决方案
这是由工作中的一个小改动需求得到的这个解决方案的:那个需求是这样的,如图: 需求原来是球队名字没有点击功能的,而蓝色方框两队之间的比赛点击的时候会跳转到比赛文字直播页面.现在需要要求点击球队名字要 ...
MACE(3)-----工程化
作者:十岁的小男孩 QQ:929994365 能下者,上. 前言本文是MACE的第三步即MACE环境编译出来的库在Android工程中的使用.在第一篇博文中通过mace官方提供的安卓工程进行调试,本 ...
kmp算法专题总结
next数组的含义:next[i]表示以字符串s的第i个字符为结尾的后缀与s前缀匹配的长度 next数组也可以当做fail数组,即当模式串s[j]与串t[i]不匹配时,只要将j转换到next[j]继续 ...
向集合中添加自定义类型--建议在自定义类型的时候要重写equals方法
package com.bjpowernode.t01list; import java.util.ArrayList; /* * 向集合中添加自定义类型 */public class TestLis ...
配置内网DNS实现内部域名解析
服务器实战目的: ü 配置内网的DNS服务器实现内网服务器的域名解析. ü 配置内网的DNS服务器减少到Internet的域名解析流量. ü 配置内网的DNS服务器实现Internet上服务器的域名 ...
Monitoring and Managing Tomcat
http://tomcat.apache.org/tomcat-7.0-doc/monitoring.html
openstack学习-创建一台云主机（七）
一.创建基础环境 1.检查网络是否正常 [root@linux-node1 ~]# openstack network agent list +---------------------------- ...
Scala入门教程---《chang哥教你一天搞定Scala》
<chang哥教你一天搞定Scala> /** * <chang哥教你一天搞定Scala> * scala是一门多范式编程语言,集成了面向对象编程和函数式编程等多种特性. * ...
024 SpringMvc的异常处理
一:说明 1.介绍 Springmvc提供HandlerExceptionResolver处理异常,包括Handler映射,数据绑定,以及目标方法执行. 2.几个接口的实现类 AnnotationMe ...

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

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

随机推荐

热门专题