axctrls.pas

这是不可多得的源代码

begin
end;

function TActiveXControl.InPlaceActivate(ActivateUI: Boolean): HResult;
var
  InPlaceActivateSent: Boolean;
  ParentWindow: HWND;
  PosRect, ClipRect: TRect;
  FrameInfo: TOleInPlaceFrameInfo;
begin
  Result := S_OK;
  FWinControl.Visible := True;
  InPlaceActivateSent := False;
  if not FInPlaceActive then
    try
      if FOleClientSite = nil then OleError(E_FAIL);
      OleCheck(FOleClientSite.QueryInterface(IOleInPlaceSite, FOleInPlaceSite));
      if FOleInPlaceSite.CanInPlaceActivate <> S_OK then OleError(E_FAIL);
      OleCheck(FOleInPlaceSite.OnInPlaceActivate);
      InPlaceActivateSent := True;
      OleCheck(FOleInPlaceSite.GetWindow(ParentWindow));
      FrameInfo.cb := SizeOf(FrameInfo);
      OleCheck(FOleInPlaceSite.GetWindowContext(FOleInPlaceFrame,
        FOleInPlaceUIWindow, PosRect, ClipRect, FrameInfo));
      if FOleInPlaceFrame = nil then OleError(E_FAIL);
      with PosRect do
        FWinControl.SetBounds(Left, Top, Right - Left, Bottom - Top);
      FWinControl.ParentWindow := ParentWindow;
      FWinControl.Visible := True;
      FInPlaceActive := True;
      FOleClientSite.ShowObject;
    except
      FInPlaceActive := False;
      FOleInPlaceUIWindow := nil;
      FOleInPlaceFrame := nil;
      if InPlaceActivateSent then FOleInPlaceSite.OnInPlaceDeactivate;
      FOleInPlaceSite := nil;
      Result := HandleException;
      Exit;
    end;
  if ActivateUI and not FUIActive then
  begin
    FUIActive := True;
    FOleInPlaceSite.OnUIActivate;
    SetFocus(FWinControl.Handle);
    FOleInPlaceFrame.SetActiveObject(Self as IOleInPlaceActiveObject, nil);
    if FOleInPlaceUIWindow <> nil then
      FOleInPlaceUIWindow.SetActiveObject(Self as IOleInPlaceActiveObject, nil);
    FOleInPlaceFrame.SetBorderSpace(nil);
    if FOleInPlaceUIWindow <> nil then
      FOleInPlaceUIWindow.SetBorderSpace(nil);
  end;
end;

procedure TActiveXControl.LoadFromStream(const Stream: IStream);
var
  OleStream: TOleStream;
begin
  OleStream := TOleStream.Create(Stream);
  try
    OleStream.ReadComponent(FControl);
  finally
    OleStream.Free;
  end;
end;

function TActiveXControl.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if IsEqualGuid(IID, ISimpleFrameSite) and
    ((FControlFactory.MiscStatus and OLEMISC_SIMPLEFRAME) = 0) then
    Result := E_NOINTERFACE
  else
  begin
    Result := inherited ObjQueryInterface(IID, Obj);
    if Result <> 0 then
      if IsEqualGuid(IID, IOleLink) then
      begin
        // Work around for an MS Access 97 bug that requires IOleLink
        // to be stubbed.
        Pointer(Obj) := nil;
        IOleLink(Obj) := TOleLinkStub.Create(Self);
      end;
  end;
end;

procedure TActiveXControl.PerformVerb(Verb: Integer);
begin
end;

function TActiveXControl.GetPropertyID(const PropertyName: WideString): Integer;
var
  PName: PWideChar;
begin
  PName := PWideChar(PropertyName);
  if PropertyName = '' then
    Result := DISPID_UNKNOWN else
    OleCheck(GetIDsOfNames(GUID_NULL, @PName, 1, GetThreadLocale,
      @Result));
end;

procedure TActiveXControl.PropChanged(const PropertyName: WideString);
var
  PropID: Integer;
begin
  PropID := GetPropertyID(PropertyName);
  PropChanged(PropID);
end;

procedure TActiveXControl.PropChanged(DispID: TDispID);
var
  Enum: IEnumConnections;
  ConnectData: TConnectData;
  Fetched: Longint;
begin
  OleCheck(FPropertySinks.EnumConnections(Enum));
  while Enum.Next(1, ConnectData, @Fetched) = S_OK do
  begin
    (ConnectData.pUnk as IPropertyNotifySink).OnChanged(DispID);
    ConnectData.pUnk := nil;
  end;
end;

function TActiveXControl.PropRequestEdit(const PropertyName: WideString): Boolean;
var
  PropID: Integer;
begin
  PropID := GetPropertyID(PropertyName);
  Result := PropRequestEdit(PropID);
end;

function TActiveXControl.PropRequestEdit(DispID: TDispID): Boolean;
var
  Enum: IEnumConnections;
  ConnectData: TConnectData;
  Fetched: Longint;
begin
  Result := True;
  OleCheck(FPropertySinks.EnumConnections(Enum));
  while Enum.Next(1, ConnectData, @Fetched) = S_OK do
  begin
    Result := (ConnectData.pUnk as IPropertyNotifySink).OnRequestEdit(DispID) = S_OK;
    ConnectData.pUnk := nil;
    if not Result then Exit;
  end;
end;

procedure TActiveXControl.RecreateWnd;
var
  WasUIActive: Boolean;
  PrevWnd: HWND;
begin
  if FWinControl.HandleAllocated then
  begin
    WasUIActive := FUIActive;
    PrevWnd := Windows.GetWindow(FWinControl.Handle, GW_HWNDPREV);
    InPlaceDeactivate;
    TWinControlAccess(FWinControl).DestroyHandle;
    if InPlaceActivate(WasUIActive) = S_OK then
      SetWindowPos(FWinControl.Handle, PrevWnd, 0, 0, 0, 0,
        SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE);
  end;
end;

procedure TActiveXControl.SaveToStream(const Stream: IStream);
var
  OleStream: TOleStream;
  Writer: TWriter;
begin
  OleStream := TOleStream.Create(Stream);
  try
    Writer := TWriter.Create(OleStream, 4096);
    try
      Writer.IgnoreChildren := True;
      Writer.WriteDescendent(FControl, nil);
    finally
      Writer.Free;
    end;
  finally
    OleStream.Free;
  end;
end;

procedure TActiveXControl.ShowPropertyDialog;
var
  Unknown: IUnknown;
  Pages: TCAGUID;
begin
  if (FOleControlSite <> nil) and
    (FOleControlSite.ShowPropertyFrame = S_OK) then Exit;
  OleCheck(GetPages(Pages));
  try
    if Pages.cElems > 0 then
    begin
      if FOleInPlaceFrame <> nil then
        FOleInPlaceFrame.EnableModeless(False);
      try
        Unknown := Self;
        OleCheck(OleCreatePropertyFrame(GetActiveWindow, 16, 16,
          PWideChar(FAmbientDispatch.DisplayName), {!!!}
          1, @Unknown, Pages.cElems, Pages.pElems,
          GetSystemDefaultLCID, 0, nil));
      finally
        if FOleInPlaceFrame <> nil then
          FOleInPlaceFrame.EnableModeless(True);
      end;
    end;
  finally
    CoFreeMem(pages.pElems);
  end;
end;

procedure TActiveXControl.SetInPlaceSite(const NewInPlaceSite: IOleInPlaceSite);
begin
  FOleInPlaceSite := NewInPlaceSite;
end;

procedure TActiveXControl.StdClickEvent(Sender: TObject);
begin
  if EventSink <> nil then IStdEvents(EventSink).Click;
end;

procedure TActiveXControl.StdDblClickEvent(Sender: TObject);
begin
  if EventSink <> nil then IStdEvents(EventSink).DblClick;
end;

procedure TActiveXControl.StdKeyDownEvent(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if EventSink <> nil then
    IStdEvents(EventSink).KeyDown(Smallint(Key), GetEventShift(Shift));
end;

procedure TActiveXControl.StdKeyPressEvent(Sender: TObject; var Key: Char);
var
  KeyAscii: Smallint;
begin
  if EventSink <> nil then
  begin
    KeyAscii := Ord(Key);
    IStdEvents(EventSink).KeyPress(KeyAscii);
    Key := Chr(KeyAscii);
  end;
end;

procedure TActiveXControl.StdKeyUpEvent(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if EventSink <> nil then
    IStdEvents(EventSink).KeyUp(Smallint(Key), GetEventShift(Shift));
end;

procedure TActiveXControl.StdMouseDownEvent(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if EventSink <> nil then
    IStdEvents(EventSink).MouseDown(GetEventButton(Button),
      GetEventShift(Shift), X, Y);
end;

procedure TActiveXControl.StdMouseMoveEvent(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  if EventSink <> nil then
    IStdEvents(EventSink).MouseMove((Byte(Shift) shr 3) and 7,
      GetEventShift(Shift), X, Y);
end;

procedure TActiveXControl.StdMouseUpEvent(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if EventSink <> nil then
    IStdEvents(EventSink).MouseUp(GetEventButton(Button),
      GetEventShift(Shift), X, Y);
end;

procedure TActiveXControl.ViewChanged;
begin
  if FAdviseSink <> nil then
  begin
    FAdviseSink.OnViewChange(DVASPECT_CONTENT, -1);
    if FAdviseFlags and ADVF_ONLYONCE <> 0 then FAdviseSink := nil;
  end;
end;

procedure TActiveXControl.WndProc(var Message: TMessage);
var
  Handle: HWnd;
  FilterMessage: Boolean;
  Cookie: Longint;

  procedure ControlWndProc;
  begin
    with Message do
      if (Msg >= OCM_BASE) and (Msg < OCM_BASE + WM_USER) then
        Msg := Msg + (CN_BASE - OCM_BASE);
    FControlWndProc(Message);
    with Message do
      if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
        Msg := Msg - (CN_BASE - OCM_BASE);
  end;

begin
  with Message do
  begin
    Handle := TWinControlAccess(FControl).WindowHandle;
    FilterMessage := ((Msg < CM_BASE) or (Msg >= $C000)) and
      (FSimpleFrameSite <> nil) and FInPlaceActive;
    if FilterMessage then
      if FSimpleFrameSite.PreMessageFilter(Handle, Msg, WParam, LParam,
        Integer(Result), Cookie) = S_FALSE then Exit;
    case Msg of
      WM_SETFOCUS, WM_KILLFOCUS:
        begin
          ControlWndProc;
          if FOleControlSite <> nil then
            FOleControlSite.OnFocus(Msg = WM_SETFOCUS);
        end;
      CM_VISIBLECHANGED:
        begin
          if FControl <> FWinControl then FWinControl.Visible := FControl.Visible;
          if not FWinControl.Visible then UIDeactivate;
          ControlWndProc;
        end;
      CM_RECREATEWND:
        begin
          if FInPlaceActive and (FControl = FWinControl) then
            RecreateWnd
          else
          begin
            ControlWndProc;
            ViewChanged;
          end;
        end;
      CM_INVALIDATE,
      WM_SETTEXT:
        begin
          ControlWndProc;
          if not FInPlaceActive then ViewChanged;
        end;
      WM_NCHITTEST:
        begin
          ControlWndProc;
          if Message.Result = HTTRANSPARENT then Message.Result := HTCLIENT;
        end;
      WM_MOUSEACTIVATE:
        begin
          ControlWndProc;
          if not FUIActive and ((Message.Result = MA_ACTIVATE) or
            (Message.Result = MA_ACTIVATEANDEAT)) and (FAmbientDispatch <> nil)
            and FAmbientDispatch.UserMode then
            InPlaceActivate(True);
        end;
    else
      ControlWndProc;
    end;
    if FilterMessage then
      FSimpleFrameSite.PostMessageFilter(Handle, Msg, WParam, LParam,
        Integer(Result), Cookie);
  end;
end;

{ TActiveXControl standard properties }

function TActiveXControl.Get_BackColor: Integer;
begin
  Result := TWinControlAccess(FControl).Color;
end;

function TActiveXControl.Get_Caption: WideString;
begin
  Result := TWinControlAccess(FControl).Caption;
end;

function TActiveXControl.Get_Enabled: WordBool;
begin
  Result := FControl.Enabled;
end;

function TActiveXControl.Get_Font: Font;
begin
  GetOleFont(TWinControlAccess(FControl).Font, Result);
end;

function TActiveXControl.Get_ForeColor: Integer;
begin
  Result := TWinControlAccess(FControl).Font.Color;
end;

function TActiveXControl.Get_HWnd: Integer;
begin
  Result := FControl.Handle;
end;

function TActiveXControl.Get_TabStop: WordBool;
begin
  Result := FControl.TabStop;
end;

function TActiveXControl.Get_Text: WideString;
begin
  Result := TWinControlAccess(FControl).Text;
end;

procedure TActiveXControl.Set_BackColor(Valu