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

时间：2022-12-18 03:49:39

文笔不行,直接上源码:

主窗口:

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.

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

事件单元:

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控件并绑定事件

相关文章