axctrls.pas

这是不可多得的源代码

  try
    if Assigned(FOnConnect) then FOnConnect(unkSink, True);
    dwCookie := AddSink(unkSink) + 1;
    Result := S_OK;
  except
    Result := HandleException;
  end;
end;

function TConnectionPoint.Unadvise(dwCookie: Longint): HResult;
begin
  Dec(dwCookie);
  if (dwCookie < 0) or (dwCookie >= FSinkList.Count) or
    (FSinkList[dwCookie] = nil) then
  begin
    Result := CONNECT_E_NOCONNECTION;
    Exit;
  end;
  try
    if Assigned(FOnConnect) then
      FOnConnect(IUnknown(FSinkList[dwCookie]), False);
    RemoveSink(dwCookie);
    Result := S_OK;
  except
    Result := HandleException;
  end;
end;

function TConnectionPoint.EnumConnections(out enumconn: IEnumConnections): HResult;
begin
  try
    enumconn := TEnumConnections.Create(Self, 0);
    Result := S_OK;
  except
    Result := HandleException;
  end;
end;

{ TEnumConnectionPoints }

type
  TEnumConnectionPoints = class(TContainedObject, IEnumConnectionPoints)
  private
    FContainer: TConnectionPoints;
    FIndex: Integer;
  protected
    { IEnumConnectionPoints }
    function Next(celt: Longint; out elt;
      pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out enumconn: IEnumConnectionPoints): HResult; stdcall;
  public
    constructor Create(Container: TConnectionPoints;
      Index: Integer);
  end;

constructor TEnumConnectionPoints.Create(Container: TConnectionPoints;
  Index: Integer);
begin
  inherited Create(IUnknown(Container.FController));
  FContainer := Container;
  FIndex := Index;
end;

{ TEnumConnectionPoints.IEnumConnectionPoints }

type
  TPointerList = array[0..0] of Pointer;

function TEnumConnectionPoints.Next(celt: Longint; out elt;
  pceltFetched: PLongint): HResult;
var
  I: Integer;
  P: Pointer;
begin
  I := 0;
  while (I < celt) and (FIndex < FContainer.FConnectionPoints.Count) do
  begin
    P := Pointer(IConnectionPoint(TConnectionPoint(
      FContainer.FConnectionPoints[FIndex])));
    IConnectionPoint(P)._AddRef;
    TPointerList(elt)[I] := P;
    Inc(I);
    Inc(FIndex);
  end;
  if pceltFetched <> nil then pceltFetched^ := I;
  if I = celt then Result := S_OK else Result := S_FALSE;
end;

function TEnumConnectionPoints.Skip(celt: Longint): HResult; stdcall;
begin
  if FIndex + celt <= FContainer.FConnectionPoints.Count then
  begin
    FIndex := FIndex + celt;
    Result := S_OK;
  end else
  begin
    FIndex := FContainer.FConnectionPoints.Count;
    Result := S_FALSE;
  end;
end;

function TEnumConnectionPoints.Reset: HResult; stdcall;
begin
  FIndex := 0;
  Result := S_OK;
end;

function TEnumConnectionPoints.Clone(
  out enumconn: IEnumConnectionPoints): HResult; stdcall;
begin
  try
    enumconn := TEnumConnectionPoints.Create(FContainer, FIndex);
    Result := S_OK;
  except
    Result := E_UNEXPECTED;
  end;
end;

{ TConnectionPoints }

constructor TConnectionPoints.Create(const AController: IUnknown);
begin    // weak reference, don't keep the controller alive
  FController := Pointer(AController);
  FConnectionPoints := TList.Create;
end;

destructor TConnectionPoints.Destroy;
begin
  FreeObjectList(FConnectionPoints);
  inherited Destroy;
end;

function TConnectionPoints.CreateConnectionPoint(const IID: TGUID;
  Kind: TConnectionKind; OnConnect: TConnectEvent): TConnectionPoint;
begin
  Result := TConnectionPoint.Create(Self, IID, Kind, OnConnect);
end;

{ TConnectionPoints.IConnectionPointContainer }

function TConnectionPoints.EnumConnectionPoints(
  out enumconn: IEnumConnectionPoints): HResult;
begin
  try
    enumconn := TEnumConnectionPoints.Create(Self, 0);
    Result := S_OK;
  except
    Result := E_UNEXPECTED;
  end;
end;

function TConnectionPoints.FindConnectionPoint(const iid: TIID;
  out cp: IConnectionPoint): HResult;
var
  I: Integer;
  ConnectionPoint: TConnectionPoint;
begin
  for I := 0 to FConnectionPoints.Count - 1 do
  begin
    ConnectionPoint := FConnectionPoints[I];
    if IsEqualGUID(ConnectionPoint.FIID, iid) then
    begin
      cp := ConnectionPoint;
      Result := S_OK;
      Exit;
    end;
  end;
  Result := CONNECT_E_NOCONNECTION;
end;

function TConnectionPoints.GetController: IUnknown;
begin
  Result := IUnknown(FController);
end;

{ TReflectorWindow }


constructor TReflectorWindow.Create(ParentWindow: HWND; Control: TControl);
begin
  inherited CreateParented(ParentWindow);
  FControl := Control;
  FInSize := True;
  try
    FControl.Parent := Self;
    FControl.SetBounds(0, 0, FControl.Width, FControl.Height);
  finally
    FInSize := False;
  end;
  SetBounds(Left, Top, FControl.Width, FControl.Height);
end;

procedure TReflectorWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or WS_CLIPCHILDREN;
end;

procedure TReflectorWindow.WMGetDlgCode(var Message: TMessage);
begin
  TWinControlAccess(FControl).WndProc(Message);
end;

procedure TReflectorWindow.WMSetFocus(var Message: TWMSetFocus);
begin
  if FControl is TWinControl then
    Windows.SetFocus(TWinControl(FControl).Handle) else
    inherited;
end;

procedure TReflectorWindow.WMSize(var Message: TWMSize);
begin
  if not FInSize then
  begin
    FInSize := True;
    try
      FControl.SetBounds(0, 0, Message.Width, Message.Height);
      SetBounds(Left, Top, FControl.Width, FControl.Height);
    finally
      FInSize := False;
    end;
  end;
  inherited;
end;

{ TOleLinkStub }

type
  TOleLinkStub = class(TInterfacedObject, IUnknown, IOleLink)
  private
    Controller: IUnknown;
  public
    constructor Create(const AController: IUnknown);
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    { IOleLink }
    function SetUpdateOptions(dwUpdateOpt: Longint): HResult;
      stdcall;
    function GetUpdateOptions(out dwUpdateOpt: Longint): HResult; stdcall;
    function SetSourceMoniker(const mk: IMoniker; const clsid: TCLSID): HResult;
      stdcall;
    function GetSourceMoniker(out mk: IMoniker): HResult; stdcall;
    function SetSourceDisplayName(pszDisplayName: POleStr): HResult;
      stdcall;
    function GetSourceDisplayName(out pszDisplayName: POleStr): HResult;
      stdcall;
    function BindToSource(bindflags: Longint; const bc: IBindCtx): HResult;
      stdcall;
    function BindIfRunning: HResult; stdcall;
    function GetBoundSource(out unk: IUnknown): HResult; stdcall;
    function UnbindSource: HResult; stdcall;
    function Update(const bc: IBindCtx): HResult; stdcall;
  end;

constructor TOleLinkStub.Create(const AController: IUnknown);
begin
  inherited Create;
  Controller := AController;
end;

{ TOleLinkStub.IUnknown }

function TOleLinkStub.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  Result := Controller.QueryInterface(IID, Obj);
end;

{ TOleLinkStub.IOleLink }

function TOleLinkStub.SetUpdateOptions(dwUpdateOpt: Longint): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.GetUpdateOptions(out dwUpdateOpt: Longint): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.SetSourceMoniker(const mk: IMoniker; const clsid: TCLSID): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.GetSourceMoniker(out mk: IMoniker): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.SetSourceDisplayName(pszDisplayName: POleStr): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.GetSourceDisplayName(out pszDisplayName: POleStr): HResult;
begin
  pszDisplayName := nil;
  Result := E_FAIL;
end;

function TOleLinkStub.BindToSource(bindflags: Longint; const bc: IBindCtx): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.BindIfRunning: HResult;
begin
  Result := S_OK;
end;

function TOleLinkStub.GetBoundSource(out unk: IUnknown): HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.UnbindSource: HResult;
begin
  Result := E_NOTIMPL;
end;

function TOleLinkStub.Update(const bc: IBindCtx): HResult;
begin
  Result := E_NOTIMPL;
end;

{ TActiveXControl }

procedure TActiveXControl.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  FOleLinkStub := TOleLinkStub.Create(nil);
  FOleLinkStub._AddRef;
  FControlFactory := Factory as TActiveXControlFactory;
  if FControlFactory.EventTypeInfo <> nil then
    FConnectionPoints.CreateConnectionPoint(FControlFactory.EventIID,
      ckSingle, EventConnect);
  FPropertySinks := FConnectionPoints.CreateConnectionPoint(IPropertyNotifySink,
    ckMulti, nil);
  FControl := FControlFactory.WinControlClass.CreateParented(ParkingWindow);
  if csReflector in FControl.ControlStyle then
    FWinControl := TReflectorWindow.Create(ParkingWindow, FControl) else
    FWinControl := FControl;
  FControlWndProc := FControl.WindowProc;
  FControl.WindowProc := WndProc;
  InitializeControl;
end;

destructor TActiveXControl.Destroy;
begin
  if Assigned(FControlWndProc) then FControl.WindowProc := FControlWndProc;
  FControl.Free;
  if FWinControl <> FControl then FWinControl.Free;
  FConnectionPoints.Free;
  FOleLinkStub := nil;
  inherited Destroy;
end;

function TActiveXControl.CreateAdviseHolder: HResult;
begin
  if FOleAdviseHolder = nil then
    Result := CreateOleAdviseHolder(FOleAdviseHolder) else
    Result := S_OK;
end;

procedure TActiveXControl.DefinePropertyPages(
  DefinePropertyPage: TDefinePropertyPage);
begin
end;

function TActiveXControl.GetPropertyString(DispID: Integer;
  var S: string): Boolean;
begin
  Result := False;
end;

function TActiveXControl.GetPropertyStrings(DispID: Integer;
  Strings: TStrings): Boolean;
begin
  Result := False;
end;

procedure TActiveXControl.GetPropFromBag(const PropName: WideString;
  DispatchID: Integer; PropBag: IPropertyBag; ErrorLog: IErrorLog);
var
  PropValue: OleVariant;
begin
  //  Note: raise an EAbort exception here to stop properties from loading
  if PropBag.Read(PWideChar(PropName), PropValue, ErrorLog) = S_OK then
    ComObj.SetDispatchPropValue(Self as IDispatch, DispatchID, PropValue);
end;

procedure TActiveXControl.PutPropInBag(const PropName: WideString;
  DispatchID: Integer; PropBag: IPropertyBag);
begin
  PropBag.Write(PWideChar(PropName), ComObj.GetDispatchPropValue(Self as IDispatch,
    DispatchID));
end;

procedure TActiveXControl.GetPropertyValue(DispID, Cookie: Integer;
  var Value: OleVariant);
begin
end;

procedure TActiveXControl.InitializeControl;