unit AxMEvnt;

{Author -- Paul Milenkovic http://userpages.chorus.net/cspeech, June 2005.
 Free software -- this source code may be freely used and redistributed, but
 no warranty is made regarding its suitability or correctness.

 A Delphi ActiveX control inherits from class TActiveXControl in unit AxCtrls
 in order to obtain default behavior common to all ActiveX controls.  Class
 TActiveXControlMultiEvent overrides class TActiveXControl from unit AxCtrls
 to permit a Delphi ActiveX control to have multiple event listeners.  To give
 a Delphi ActiveX control this feature, 1) add AxMEvnt to the uses clause
 following AxCtrls, 2) derive the ActiveX control from TActiveXControlMultiEvent
 in place of TActiveXControl, and 3) add

   inherited InitializeControl;

 as the first line of the InitializeControl method.  Calling the
 InitializeControl method inherited from TActiveXControlMultiEvent insures
 that the single-listener connection point object is removed and a
 multi-listener connection point object for your control's event interface
 is substituted.

 The Delphi implementation of an ActiveX control imposes the restriction
 that only a single listener may be registered for that control's events.
 This restriction means the Python language cannot support events for
 ActiveX controls written in Delphi -- the Python ActiveX module doubly
 registers event listeners owing to implementation details.  Matlab Version 7
 also has this problem although this was not an issue with earlier Matlab
 versions.

 Delphi allows events to have function and var-parameter return values.
 Delphi then restricts events to a single listener because otherwise return
 values from multiple listeners would not make sense.  Many ActiveX control
 containers, however, don't support return values from events anyway.  If your
 ActiveX control events lack return values, enabling multiple event
 registration is OK.

 The simplest way for Delphi to allow multiple event listeners would be to
 patch the unit AxCtrls to change the flag ckSingle in

   procedure TActiveXControl.Initialize;
   begin
      . . .
     if FControlFactory.EventTypeInfo <> nil then
       FConnectionPoints.CreateConnectionPoint(FControlFactory.EventIID,
         ckSingle, EventConnect);
      . . .
   end;

 to the flag ckMulti as in

   procedure TActiveXControl.Initialize;
   begin
      . . .
     if FControlFactory.EventTypeInfo <> nil then
       FConnectionPoints.CreateConnectionPoint(FControlFactory.EventIID,
         ckMulti, EventConnect);
      . . .
   end;

 You can make this patch local to your project by copying and editing
 AxCtrls.pas from the Delphi runtime library to your project source directory.
 You also have to disable runtime packages.  This approach also has the
 disadvantage if you wanted to distribute source code to your ActiveX control
 because the AxCtrls module has a Borland copyright.

 This module supports the alternate approach of using derived class
 TActiveXControlMultiEvent to override the single-listener event restriction
 of the base TActiveXControl class.
}

interface

uses ActiveX, AxCtrls;

type
  TActiveXControlMultiEvent = class(TActiveXControl)
  protected
    procedure InitializeControl; override;
  end;

implementation

{The TActiveXControl.Initialize method registers a single-listener
 connection point object for the ActiveX control's event interface.  After
 that, it calls InitializeControl.  The TActiveXControlMultiEvent class
 overrides InitializeControl to unregister the single-listener
 connection point and register a multi-listener connection point object
 in its place.

 The only way I know to get at the already-registered single-listener
 connection point object is to invoke FindConnectionPoint on the connection
 point collection object called a "connection point container."  That
 function returns the IConnectionPoint interface; if we could get at the
 underlying connection point object, we can safely Free it because it is
 a Delphi TContainedObject that depends on its containing collection
 instead of the reference count to manage its lifetime and because it removes
 itself from the connection point collection in its destructor.  Unfortunately,
 simply casting an interface to the parent object and invoking Free results
 in a runtime error because the interface and the parent object have different
 virtual method tables pointers at different offsets within the object instance.

 The following GetImplementingObject is a safe way of getting a reference
 to the underlying object given an interface to that object.  It is due to
 Deepak Shenoy at
   http://shenoyatwork.blogspot.com/2004_06_01_shenoyatwork_archive.html
 who in turn references Hallvard Vassbotn at
   http://hallvards.blogspot.com/
}

function GetImplementingObject(const I: IInterface): TObject;
const
  AddByte = $04244483; // opcode : ADD DWORD PTR [ESP+4],
                       //          Shortint
  AddLong = $04244481; // opcode : ADD DWORD PTR [ESP+4],
                       //          Longint
type
  PAdjustSelfThunk = ^TAdjustSelfThunk;
  TAdjustSelfThunk = packed record
    case AddInstruction: longint of
      AddByte : (AdjustmentByte: shortint);
      AddLong : (AdjustmentLong: longint);
  end;
  PInterfaceMT = ^TInterfaceMT;
  TInterfaceMT = packed record
    QueryInterfaceThunk: PAdjustSelfThunk;
  end;
  TInterfaceRef = ^PInterfaceMT;
var
  QueryInterfaceThunk: PAdjustSelfThunk;
begin
  Result := Pointer(I);
  if Assigned(Result) then
    try
      QueryInterfaceThunk :=
           TInterfaceRef(I)^.QueryInterfaceThunk;
      case QueryInterfaceThunk.AddInstruction of
        AddByte: Inc(PChar(Result),
                    QueryInterfaceThunk.AdjustmentByte);
        AddLong: Inc(PChar(Result),
                    QueryInterfaceThunk.AdjustmentLong);
        else     Result := nil;
      end;
    except
      Result := nil;
    end;
end;

procedure TActiveXControlMultiEvent.InitializeControl;
  var cp: IConnectionPoint;
      co: TObject;
begin
  // Check if our control has an event interface.
  if (Factory as TActiveXControlFactory).EventTypeInfo <> nil then begin
    // We cannot call FindConnectionPoint on the TConnectionPoints object
    // held in property variable ConnectionPoints because it is . . .
    // protected!  We can, however, call FindConnectionPoint on the
    // IConnectionPointContainer interface using the
    //   Self as IConnectionPointContainer
    // syntax because a TActiveXControl object implements that interface
    // and forwards that call to the TConnectionPoints object referenced
    // by the ConnectionPoints property.
    if (Self as IConnectionPointContainer).FindConnectionPoint(
         (Factory as TActiveXControlFactory).EventIID,cp) = S_OK
    then begin
      // Gets underlying connection object from IConnectionPoint interface --
      // the simple cast of co := TObject(cp) does not work.
      co := GetImplementingObject(cp);
      // Setting cp := nil decrements a reference count held by cp now.
      // Otherwise if cp != nil when it goes out of scope, an attempt will be
      // made to decrement the reference count of cp after the underlying
      // object has been deallocated.
      cp := nil;
      // Unregisters the default single-listener connection point.
      co.Free;
    end;
    // Registers a multi-listener connection point.
    ConnectionPoints.CreateConnectionPoint(
      (Factory as TActiveXControlFactory).EventIID,ckMulti,EventConnect);
  end;
end;

end.