rm_jvexcontrols.pas

这是一个功能强大

    {$ENDIF !CLR}
    procedure VisibleChanged; reintroduce; dynamic;
    procedure EnabledChanged; reintroduce; dynamic;
    procedure TextChanged; reintroduce; virtual;
    procedure ColorChanged; reintroduce; dynamic;
    procedure FontChanged; reintroduce; dynamic;
    procedure ParentFontChanged; reintroduce; dynamic;
    procedure ParentColorChanged; reintroduce; dynamic;
    procedure ParentShowHintChanged; reintroduce; dynamic;
    function WantKey(Key: Integer; Shift: TShiftState; const KeyText: WideString): Boolean; reintroduce; virtual;
    function HintShow(var HintInfo: THintInfo): Boolean; reintroduce; dynamic;
    function HitTest(X, Y: Integer): Boolean; reintroduce; virtual;
    procedure MouseEnter(AControl: TControl); reintroduce; dynamic;
    procedure MouseLeave(AControl: TControl); reintroduce; dynamic;
    {$IFDEF COMPILER5}
    {$IFNDEF HASAUTOSIZE}
    procedure CMSetAutoSize(var Msg: TMessage); message CM_SETAUTOSIZE;
    procedure SetAutoSize(Value: Boolean); virtual;
    {$ENDIF !HASAUTOSIZE}
    {$ENDIF COMPILER5}
    property MouseOver: Boolean read FMouseOver write FMouseOver;
    property HintColor: TColor read FHintColor write FHintColor default clDefault;
    {$IFDEF VCL}
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    {$ENDIF VCL}
    property OnParentColorChange: TNotifyEvent read FOnParentColorChanged write FOnParentColorChanged;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property AboutJVCL: TJVCLAboutInfo read FAboutJVCL write FAboutJVCL stored False;
  private
    FDotNetHighlighting: Boolean;
  protected
    procedure BoundsChanged; reintroduce; virtual;
    procedure CursorChanged; reintroduce; dynamic;
    procedure ShowingChanged; reintroduce; dynamic;
    procedure ShowHintChanged; reintroduce; dynamic;
    {$IFNDEF CLR}
    procedure ControlsListChanging(Control: TControl; Inserting: Boolean); reintroduce; dynamic;
    procedure ControlsListChanged(Control: TControl; Inserting: Boolean); reintroduce; dynamic;
    {$ENDIF !CLR}
    procedure GetDlgCode(var Code: TDlgCodes); virtual;
    procedure FocusSet(PrevWnd: THandle); virtual;
    procedure FocusKilled(NextWnd: THandle); virtual;
    function DoEraseBackground(Canvas: TCanvas; Param: Integer): Boolean; virtual;
  {$IFDEF JVCLThemesEnabledD56}
  private
    function GetParentBackground: Boolean;
  protected
    procedure SetParentBackground(Value: Boolean); virtual;
    property ParentBackground: Boolean read GetParentBackground write SetParentBackground;
  {$ENDIF JVCLThemesEnabledD56}
  published
    property DotNetHighlighting: Boolean read FDotNetHighlighting write FDotNetHighlighting default False;
  end;

  TJvExPubGraphicControl = class(TJvExGraphicControl)
  published
    property BiDiMode;
    property DragCursor;
    property DragKind;
    property DragMode;
    property ParentBiDiMode;
    property OnEndDock;
    property OnStartDock;
  end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile$';
    Revision: '$Revision: 10226 $';
    Date: '$Date: 2006-01-24 09:31:03 -0800 (Tue, 24 Jan 2006) $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  TypInfo;

var
  InternalFocusedColor: TColor = TColor($00733800);
  InternalUnfocusedColor: TColor = clGray;

procedure SetDotNetFrameColors(FocusedColor, UnfocusedColor: TColor);
begin
  InternalFocusedColor := FocusedColor;
  InternalUnfocusedColor := UnfocusedColor;
end;

procedure DrawDotNetControl(Control: TWinControl; AColor: TColor; InControl: Boolean);
var
  DC: HDC;
  R: TRect;
  Canvas: TCanvas;
begin
  DC := GetWindowDC(Control.Handle);
  try
    GetWindowRect(Control.Handle, R);
    OffsetRect(R, -R.Left, -R.Top);
    Canvas := TCanvas.Create;
    with Canvas do
    try
      Handle := DC;
      Brush.Color := InternalUnfocusedColor;
      if Control.Focused or InControl then
        Brush.Color := InternalFocusedColor;
      FrameRect(R);
      InflateRect(R, -1, -1);
      if not (Control.Focused or InControl) then
        Brush.Color := AColor;
      FrameRect(R);
    finally
      Free;
    end;
  finally
    ReleaseDC(Control.Handle, DC);
  end;
end;

procedure HandleDotNetHighlighting(Control: TWinControl; const Msg: TMessage;
  MouseOver: Boolean; Color: TColor);
var
  Rgn, SubRgn: HRGN;
begin
  if not (csDesigning in Control.ComponentState) then
    case Msg.Msg of
      CM_MOUSEENTER, CM_MOUSELEAVE, WM_KILLFOCUS, WM_SETFOCUS, WM_NCPAINT:
        begin
          DrawDotNetControl(Control, Color, MouseOver);
          if Msg.Msg = CM_MOUSELEAVE then
          begin
            Rgn := CreateRectRgn(0, 0, Control.Width - 1, Control.Height - 1);
            SubRgn := CreateRectRgn(2, 2, Control.Width - 3, Control.Height - 3);
            try
              CombineRgn(Rgn, Rgn, SubRgn, RGN_DIFF);
              InvalidateRgn(Control.Handle, Rgn, False); // redraw 3D border
            finally
              DeleteObject(SubRgn);
              DeleteObject(Rgn);
            end;
          end;
        end;
    end;
end;

function CreateWMMessage(Msg: Integer; WParam: Integer; LParam: Longint): TMessage;
begin
  {$IFNDEF CLR}
  Result.Msg := Msg;
  Result.WParam := WParam;
  Result.LParam := LParam;
  {$ELSE}
  Result := TMessage.Create(Msg, WParam, LParam);
  {$ENDIF CLR}
  Result.Result := 0;
end;

function CreateWMMessage(Msg: Integer; WParam: Integer; LParam: TControl): TMessage;
begin
  {$IFNDEF CLR}
  Result := CreateWMMessage(Msg, WParam, Integer(LParam));
  {$ELSE}
  Result := CreateWMMessage(Msg, WParam, 0);
  {$ENDIF !CLR}
end;

{ TStructPtrMessage }
constructor TStructPtrMessage.Create(Msg: Integer; WParam: Integer; var LParam);
begin
  inherited Create;
  {$IFNDEF CLR}
  Self.Msg.Msg := Msg;
  Self.Msg.WParam := WParam;
  Self.Msg.LParam := Longint(@LParam);
  {$ELSE}
  FBuf := Marshal.AllocHGlobal(Marshal.SizeOf(TObject(LParam)));
  FLParam := &Object(LParam);
  Marshal.StructureToPtr(FLParam, FBuf, False);
  Self.Msg := TMessage.Create(Msg, WParam, Longint(FBuf));
  {$ENDIF !CLR}
  Self.Msg.Result := 0;
end;

{$IFDEF CLR}
destructor TStructPtrMessage.Destroy;
begin
  FLParam := Marshal.PtrToStructure(FBuf, TypeOf(FLParam));
  Marshal.DestroyStructure(FBuf, TypeOf(FLParam));
  inherited Destroy;
end;
{$ENDIF CLR}

function SmallPointToLong(const Pt: TSmallPoint): Longint;
begin
  {$IFDEF CLR}
  Result := Int32(Pt.X) shl 16 or Pt.Y;
  {$ELSE}
  Result := Longint(Pt);
  {$ENDIF CLR}
end;

function ShiftStateToKeyData(Shift: TShiftState): Longint;
const
  AltMask = $20000000;
  CtrlMask = $10000000;
  ShiftMask = $08000000;
begin
  Result := 0;
  if ssAlt in Shift then
    Result := Result or AltMask;
  if ssCtrl in Shift then
    Result := Result or CtrlMask;
  if ssShift in Shift then
    Result := Result or ShiftMask;
end;

function GetFocusedControl(AControl: TControl): TWinControl;
var
  Form: TCustomForm;
begin
  Result := nil;
  Form := GetParentForm(AControl);
  if Assigned(Form) then
    {$IFDEF VCL}
    Result := Form.ActiveControl;
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    Result := Form.FocusedControl;
    {$ENDIF VisualCLX}
end;

function DlgcToDlgCodes(Value: Longint): TDlgCodes;
begin
  Result := [];
  if (Value and DLGC_WANTARROWS) <> 0 then
    Include(Result, dcWantArrows);
  if (Value and DLGC_WANTTAB) <> 0 then
    Include(Result, dcWantTab);
  if (Value and DLGC_WANTALLKEYS) <> 0 then
    Include(Result, dcWantAllKeys);
  if (Value and DLGC_WANTCHARS) <> 0 then
    Include(Result, dcWantChars);
  if (Value and DLGC_BUTTON) <> 0 then
    Include(Result, dcButton);
  if (Value and DLGC_HASSETSEL) <> 0 then
    Include(Result, dcHasSetSel);
end;

function DlgCodesToDlgc(Value: TDlgCodes): Longint;
begin
  Result := 0;
  if dcWantAllKeys in Value then
    Result := Result or DLGC_WANTALLKEYS;
  if dcWantArrows in Value then
    Result := Result or DLGC_WANTARROWS;
  if dcWantTab in Value then
    Result := Result or DLGC_WANTTAB;
  if dcWantChars in Value then
    Result := Result or DLGC_WANTCHARS;
  if dcButton in Value then
    Result := Result or DLGC_BUTTON;
  if dcHasSetSel in Value then
    Result := Result or DLGC_HASSETSEL;
end;

procedure GetHintColor(var HintInfo: THintInfo; AControl: TControl; HintColor: TColor);
var
  AHintInfo: THintInfo;
begin
  case HintColor of
    clNone:
      HintInfo.HintColor := Application.HintColor;
    clDefault:
      begin
        if Assigned(AControl) and Assigned(AControl.Parent) then
        begin
          AHintInfo := HintInfo;
          {$IFNDEF CLR}
          {$IFDEF VCL}
          AControl.Parent.Perform(CM_HINTSHOW, 0, Integer(@AHintInfo));
          {$ENDIF VCL}
          {$IFDEF VisualCLX}
          Perform(AControl.Parent, CM_HINTSHOW, 0, Integer(@AHintInfo));
          {$ENDIF VisualCLX}
          {$ELSE}
          AControl.Parent.Perform(CM_HINTSHOW, 0, AHintInfo);
          {$ENDIF !CLR}
          HintInfo.HintColor := AHintInfo.HintColor;
        end;
      end;
  else
    HintInfo.HintColor := HintColor;
  end;
end;

function DispatchIsDesignMsg(Control: TControl; var Msg: TMessage): Boolean;
var
  Form: TCustomForm;
begin
  Result := False;
  case Msg.Msg of
    WM_SETFOCUS, WM_KILLFOCUS, WM_NCHITTEST,
    WM_MOUSEFIRST..WM_MOUSELAST,
    WM_KEYFIRST..WM_KEYLAST,
    WM_CANCELMODE:
      Exit; // These messages are handled in TWinControl.WndProc before IsDesignMsg() is called
  end;
  if (Control <> nil) and (csDesigning in Control.ComponentState) then
  begin
    Form := GetParentForm(Control);
    if (Form <> nil) and (Form.Designer <> nil) and
       Form.Designer.IsDesignMsg(Control, Msg) then
      Result := True;
  end;
end;

{$IFDEF VisualCLX}
function Perform(AControl: TControl; Msg: Integer; WParam, LParam: Integer): Integer;
var
  PerformMsg, Mesg: TMessage;
begin
  if AControl.GetInterfaceEntry(IJvExControl) <> nil then
  begin
    Mesg.Msg := Msg;
    Mesg.WParam := WParam;
    Mesg.LParam := LParam;
    Mesg.Result := 0;

    PerformMsg.Msg := CM_PERFORM;
    PerformMsg.WParam := 0;
    PerformMsg.LParam := @Mesg;
    PerformMsg.Result := 0;
    AControl.Dispatch(PerformMsg);
  end;
end;
{$ENDIF VisualCLX}

{$IFDEF COMPILER5}

{ Delphi 5's SetAutoSize is private and not virtual. This code installs a
  JUMP-Hook into SetAutoSize that jumps to our function. }
var
  AutoSizeOffset: Cardinal;
  TControl_SetAutoSize: Pointer;

type
  PBoolean = ^Boolean;
  TControlAccessProtected = class(TControl)
  published
    property AutoSize;
  end;

procedure OrgSetAutoSize(AControl: TControl; Value: Boolean);
asm
        DD    0, 0, 0, 0  // 16 Bytes
end;

procedure TOpenControl_SetAutoSize(AControl: TControl; Value: Boolean);
begin
  // same as OrgSetAutoSize(AControl, Value); but secure
  with TControlAccessProtected(AControl) do
    if AutoSize <> Value then
    begin
      PBoolean(Cardinal(AControl) + AutoSizeOffset)^ := Value;
      if Value then
        AdjustSize;
    end;
end;

procedure SetAutoSizeHook(AControl: TControl; Value: Boolean);
var
  Msg: TMessage;
begin
  if AControl.GetInterfaceEntry(IJvExControl) <> nil then
  begin
    Msg.Msg := CM_SETAUTOSIZE;
    Msg.WParam := Ord(Value);
    AControl.Dispatch(Msg);
  end
  else
    TOpenControl_SetAutoSize(AControl, Value);
end;

procedure InitHookVars;
var
  Info: PPropInfo;
begin
  Info := GetPropInfo(TControlAccessProtected, 'AutoSize');
  AutoSizeOffset := Integer(Info.GetProc) and $00FFFFFF;
  TControl_SetAutoSize := Info.SetProc;
end;

{$ENDIF COMPILER5}

//=== { TJvHotTrackOptions } ======================================

constructor TJvHotTrackOptions.Create;
begin
  inherited Create;
  FEnabled := False;
  FFrameVisible := False;
  FColor := $00D2BDB6;
  FFrameColor := $006A240A;
end;

procedure TJvHotTrackOptions.Assign(Source: TPersistent);
begin
  if Source is TJvHotTrackOptions then
  begin
    BeginUpdate;
    try
      Enabled := TJvHotTrackOptions(Source).Enabled;
      Color := TJvHotTrackOptions(Source).Color;
      FrameVisible := TJvHotTrackOptions(Source).FrameVisible;
      FrameColor := TJvHotTrackOptions(Source).FrameColor;
    finally
      EndUpdate;
    end;
  end
  else
    inherited Assign(Source);
end;

procedure TJvHotTrackOptions.SetColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    Changing;