Delphi动态调用ocx

以下代码不记得从哪里复制过来的，里面加了点自己的改动

unit EventSink;

interface

uses
  Windows, Messages, SysUtils, Classes,
  Graphics, Controls, Forms, Dialogs,
  ActiveX;

type
  // 在原有参数的基础上,增加了 ConnectDispatch: IDispatch ;
  // 加此原因是同时捕捉多个串口的数据,在进行 Connect时传入了对应的IDispatch指针
  // 在Invoke事件中,就直接调用此 IDispatch ,避免了调用处再寻找的过程
  TInvokeEvent = procedure(Sender: TObject; ConnectDispatch: IDispatch ;
    const mComType: Integer ; // Wicher 2018-01-08 Add
    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;
    FComType: Integer ;
  protected
    { Protected declarations }
    procedure DoInvoke(ConnectDispatch: IDispatch ;
      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; const mComType: Integer = -1);
  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;

{
只要搞懂invoke各参数你就会调用了~~
function Invoke(
  DispID: Integer; // DispID参数指定了要执行的方法的调度号，可用GetIDsOfNames得到
  const IID: TGUID; // 此参数无用, 以后或许会有用
  LocaleID: Integer; // 语言页代号, 也可以不予理会
  // DISPATCH_METHOD , DISPATCH_PROPERTYGET  , DISPATCH_PROPERTYPUT , DISPATCH_PROPERTYPUTREF
  Flags: Word; // 要执行的方法类型(一般方法/属性读方法/属性写方法/引用赋值方法) 
  var Params; // 参数列表, 下面会继续给出使用方法
  VarResult, // 返回所调用方法的返回值, 指向OleVariant类型
  ExcepInfo, // 指向一个TExcepInfo异常记录, 当invoke返回DISP_E_EXCEPTION时有效
  ArgErr: Pointer // 发生错误用此可知参数列表(Params)中那个参数有误
): HResult; stdcall;

Params参数列表指针指向一个tagDispParams结构
tagDISPPARAMS = record
  rgvarg: PVariantArgList;  // 参数列表, 指向一个变体数组, 可用VarArrayCreate构造
  rgdispidNamedArgs: PDispIDList; // 命名参数的调度号列表
  cArgs: Longint; // 参数个数
  cNamedArgs: Longint; // 命名参数个数
end;
TDispParams = tagDISPPARAMS;

也就是说，调用一个未知的方法，通常需要经过如下几步
1 用GetIdsOfNames得到方法名的编号
2 用VarArrayCreate构千一个变体数组，并对各参数赋值
3 生成一条tagDispParams记录, 其中含有参数信息
4 根据得到的方法编号及参数列表调用invoke
}

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(Self.FDispatch, 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; const mComType: Integer = -1);
begin
  FComType := mComType ;
  FSink.Connect(AnAppDispatch, AnAppDispIntfIID);
end;

constructor TEventSink.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSink := TAbstractEventSink.Create(Self);
  FComType := -1 ;
end;

destructor TEventSink.Destroy;
begin
  FSink.Free;

  inherited Destroy;
end;

procedure TEventSink.DoInvoke(ConnectDispatch: IDispatch ;
  DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer);
begin
  if Assigned(FOnInvoke) then
    FOnInvoke(Self, ConnectDispatch, FComType, DispID, IID, LocaleID, Flags, TDispParams(Params),
      VarResult, ExcepInfo, ArgErr);
end;

end.

//*************** 调用 mscomm32.ocx *******************

uses ActiveX, ComObj, Windows, OleCtrls

type
  InputModeConstants = TOleEnum;
  const
    comInputModeText = $00000000;
    comInputModeBinary = $00000001;

    comEvSend = $00000001;
    comEvReceive = $00000002;
    comEvCTS = $00000003;
    comEvDSR = $00000004;
    comEvCD = $00000005;
    comEvRing = $00000006;
    comEvEOF = $00000007;

type
  IMSCommDisp = dispinterface
     ['{E6E17E90-DF38-11CF-8E74-00A0C90F26F8}']
   {
    property CDHolding: WordBool dispid 1;
    property CDTimeout: Integer dispid 2;
    property CommID: Integer dispid 3;
    property CommPort: Smallint dispid 4;
    property _CommPort: Smallint dispid 0;
    property CTSHolding: WordBool dispid 5;
    property CTSTimeout: Integer dispid 6;
    property DSRHolding: WordBool dispid 7;
    property DSRTimeout: Integer dispid 8;
    property DTREnable: WordBool dispid 9;
    property Handshaking: HandshakeConstants dispid 10;
   }
    property InBufferSize: Smallint dispid 11;
    property InBufferCount: Smallint dispid 12;
   {
    property Break: WordBool dispid 13;
    property InputLen: Smallint dispid 14;
    property Interval: Integer dispid 15;
    property NullDiscard: WordBool dispid 16;
    property OutBufferSize: Smallint dispid 17;
    property OutBufferCount: Smallint dispid 18;
    property ParityReplace: WideString dispid 19;
    property PortOpen: WordBool dispid 20;
    property RThreshold: Smallint dispid 21;
    property RTSEnable: WordBool dispid 22;
    property Settings: WideString dispid 23;
    property SThreshold: Smallint dispid 24;
    property Output: OleVariant dispid 25;
    }
    property Input: OleVariant dispid 26;
    property CommEvent: Smallint dispid 27;
    // property EOFEnable: WordBool dispid 28;
    property InputMode: InputModeConstants dispid 29;
    // procedure AboutBox; dispid -552;
  end;

  DMSCommEvents = dispinterface
    ['{648A5602-2C6E-101B-82B6-000000000014}']
    procedure OnComm; dispid 1;
  end;

const
  //********** MS-comm *************
  CLASS_MSComm: TGUID = '{648A5600-2C6E-101B-82B6-000000000014}';
  IID_IMSComm: TGUID = '{E6E17E90-DF38-11CF-8E74-00A0C90F26F8}';
  IID_DMSCommEvents: TGUID = '{648A5602-2C6E-101B-82B6-000000000014}';
 
var
 mEventSink_MS: TEventSink ;
 mActiveXCon_MS: Variant;

mActiveXCon_MS := CreateComObjectFromDll(CLASS_MSComm, FMsComm32Handle ) as IDispatch;

if VarIsNull(mActiveXCon_MS) then
begin
  Result := False;
  Exit;
end;

mEventSink_MS := TEventSink.Create(Self);
mEventSink_MS.Name := 'COM1' ;
mEventSink_MS.OnInvoke := EventSinkInvoke_MS;

mEventSink_MS.Connect(mActiveXCon_MS, IID_DMSCommEvents, mMyMsComCfg.ComType);
if (mActiveXCon_MS.PortOpen) then
begin
  mActiveXCon_MS.PortOpen := False ;
end ;

function CreateComObjectFromDll(CLSID: TGUID; DllHandle: THandle): IUnknown;
var
  Factory: IClassFactory;
  DllGetClassObject: function(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
  hr: HRESULT;
begin
  // 获得COM的类厂
  DllGetClassObject := GetProcAddress(DllHandle, 'DllGetClassObject');
  if Assigned(DllGetClassObject) then
  begin
    hr := DllGetClassObject(CLSID, IClassFactory, Factory);
    if hr = S_OK then
    try
      // //成功获得COM接口
      hr := Factory.CreateInstance(nil, IUnknown, Result);
      if hr <> S_OK then
      begin
        ShowMessage('Error');
      end;
    except
      ShowMessage(IntToStr(GetLastError));
    end;
  end;

procedure TFrmMain.EventSinkInvoke_MS(Sender: TObject; ConnectDispatch: IDispatch ;
  const mComType: Integer ; // Wicher Add
  DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; Params: tagDISPPARAMS;
  VarResult, ExcepInfo, ArgErr: Pointer);
var
  mIMSCommDisp : IMSCommDisp ;
  mRecDataArray :array of Variant;
begin
 {
  Flags值定义 :
  DISPATCH_METHOD         = $1;
  DISPATCH_PROPERTYGET    = $2;
  DISPATCH_PROPERTYPUT    = $4;
  DISPATCH_PROPERTYPUTREF = $8;
  DISPATCH_CONSTRUCT      = $4000;

    这里需要注明Params这个参数, 包含了事件的参数
    如：
    Params.rgvarg[0] 代表第一个参数
    Params.rgvarg[1] 代表第二个参数
    ......
    Params.rgvarg[65535] 代表第65535个参数
    最多65535个参数
    具体可以参考 tagDISPPARAMS 的定义</p><p>    这里只列出了怎么扑获相关事件，具体功能具体实现
  }

  case dispid of
  $00000001:
    begin
      mIMSCommDisp := nil ;
      mIMSCommDisp := (ConnectDispatch AS IMSCommDisp) ;
      if AsSigned(mIMSCommDisp) then
      begin
        if mIMSCommDisp.CommEvent = comEvReceive then
        begin
          if mIMSCommDisp.InputMode = comInputModeText then
          begin
           
          end
          else begin
            // 二进制
           
          end ;
        end ;
      end ;
    end ;
  end ;
end;