rxgrdcpt.pas

RX Library contains a large number of components, objects and routines for Borland Delphi with full

{*******************************************************}
{                                                       }
{     Delphi VCL Extensions (RX)                        }
{                                                       }
{     Copyright (c) 1997 Master-Bank                    }
{     Copyright (c) 1998 Ritting Information Systems    }
{                                                       }
{*******************************************************}

unit RxGrdCpt;

{$I RX.INC}

interface

{$IFDEF WIN32}

uses Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus,
  RxHook, VclUtils;

type
  THideDirection = (hdLeftToRight, hdRightToLeft);

  TRxCaption = class;
  TRxCaptionList = class;

{ TRxGradientCaption }

  TRxGradientCaption = class(TComponent)
  private
    FActive: Boolean;
    FWindowActive: Boolean;
    FSaveRgn: HRgn;
    FRgnChanged: Boolean;
    FWinHook: TRxWindowHook;
    FStartColor: TColor;
    FCaptions: TRxCaptionList;
    FFont: TFont;
    FDefaultFont: Boolean;
    FPopupMenu: TPopupMenu;
    FClicked: Boolean;
    FHideDirection: THideDirection;
    FGradientInactive: Boolean;
    FGradientActive: Boolean;
    FFontInactiveColor: TColor;
    FFormCaption: string;
    FGradientSteps: Integer;
    FOnActivate: TNotifyEvent;
    FOnDeactivate: TNotifyEvent;
    procedure SetHook;
    procedure ReleaseHook;
    procedure CheckToggleHook;
    function GetActive: Boolean;
    procedure SetActive(Value: Boolean);
    procedure SetStartColor(Value: TColor);
    procedure DrawGradientCaption(DC: HDC);
    procedure CalculateGradientParams(var R: TRect; var Icons: TBorderIcons);
    function GetForm: TForm;
    function GetFormCaption: string;
    procedure SetFormCaption(const Value: string);
    procedure BeforeMessage(Sender: TObject; var Msg: TMessage;
      var Handled: Boolean);
    procedure AfterMessage(Sender: TObject; var Msg: TMessage;
      var Handled: Boolean);
    function CheckMenuPopup(X, Y: Integer): Boolean;
    procedure SetFont(Value: TFont);
    procedure FontChanged(Sender: TObject);
    procedure SetDefaultFont(Value: Boolean);
    procedure SetFontDefault;
    function IsFontStored: Boolean;
    function GetTextWidth: Integer;
    procedure SetCaptions(Value: TRxCaptionList);
    procedure SetGradientActive(Value: Boolean);
    procedure SetGradientInactive(Value: Boolean);
    procedure SetGradientSteps(Value: Integer);
    procedure SetFontInactiveColor(Value: TColor);
    procedure SetHideDirection(Value: THideDirection);
    procedure SetPopupMenu(Value: TPopupMenu);
  protected
    procedure Loaded; override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
{$IFDEF RX_D4}
    function IsRightToLeft: Boolean;
{$ENDIF}
    property Form: TForm read GetForm;
    property TextWidth: Integer read GetTextWidth;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure MoveCaption(FromIndex, ToIndex: Integer);
    procedure Update;
    procedure Clear;
  published
    property Active: Boolean read GetActive write SetActive default True;
    property Captions: TRxCaptionList read FCaptions write SetCaptions;
    property DefaultFont: Boolean read FDefaultFont write SetDefaultFont default True;
    property FormCaption: string read GetFormCaption write SetFormCaption;
    property FontInactiveColor: TColor read FFontInactiveColor
      write SetFontInactiveColor default clInactiveCaptionText;
    property Font: TFont read FFont write SetFont stored IsFontStored;
    property GradientActive: Boolean read FGradientActive
      write SetGradientActive default True;
    property GradientInactive: Boolean read FGradientInactive
      write SetGradientInactive default False;
    property GradientSteps: Integer read FGradientSteps write SetGradientSteps
      default 64;
    property HideDirection: THideDirection read FHideDirection
      write SetHideDirection default hdLeftToRight;
    property PopupMenu: TPopupMenu read FPopupMenu write SetPopupMenu;
    property StartColor: TColor read FStartColor write SetStartColor
      default clWindowText;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
  end;

{ TRxCaptionList }

  TRxCaptionList = class(TCollection)
  private
    FParent: TRxGradientCaption;
    function GetCaption(Index: Integer): TRxCaption;
    procedure SetCaption(Index: Integer; Value: TRxCaption);
  protected
{$IFDEF RX_D3}
    function GetOwner: TPersistent; override;
{$ENDIF}
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AParent: TRxGradientCaption);
    function Add: TRxCaption;
    procedure RestoreDefaults;
    property Parent: TRxGradientCaption read FParent;
    property Items[Index: Integer]: TRxCaption read GetCaption write SetCaption; default;
  end;

{ TRxCaption }

  TRxCaption = class(TCollectionItem)
  private
    FCaption: string;
    FFont: TFont;
    FParentFont: Boolean;
    FVisible: Boolean;
    FGlueNext: Boolean;
    FInactiveColor: TColor;
    procedure SetCaption(const Value: string);
    procedure SetFont(Value: TFont);
    procedure SetParentFont(Value: Boolean);
    procedure FontChanged(Sender: TObject);
    function IsFontStored: Boolean;
    function GetTextWidth: Integer;
    procedure SetVisible(Value: Boolean);
    procedure SetInactiveColor(Value: TColor);
    procedure SetGlueNext(Value: Boolean);
  protected
    function GetParentCaption: TRxGradientCaption;
    property TextWidth: Integer read GetTextWidth;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure RestoreDefaults; virtual;
    property GradientCaption: TRxGradientCaption read GetParentCaption;
  published
    property Caption: string read FCaption write SetCaption;
    property Font: TFont read FFont write SetFont stored IsFontStored;
    property ParentFont: Boolean read FParentFont write SetParentFont
      default True;
    property InactiveColor: TColor read FInactiveColor write SetInactiveColor
      default clInactiveCaptionText;
    property GlueNext: Boolean read FGlueNext write SetGlueNext default False;
    property Visible: Boolean read FVisible write SetVisible default True;
  end;

function GradientFormCaption(AForm: TCustomForm;
  AStartColor: TColor): TRxGradientCaption;

{$ENDIF WIN32}

implementation

{$IFDEF WIN32}

uses SysUtils, AppUtils;

function GradientFormCaption(AForm: TCustomForm;
  AStartColor: TColor): TRxGradientCaption;
begin
  Result := TRxGradientCaption.Create(AForm);
  with Result do
    try
      FStartColor := AStartColor;
      FormCaption := AForm.Caption;
      Update;
    except
      Free;
      raise;
    end;
end;

{ TRxCaptionList }

constructor TRxCaptionList.Create(AParent: TRxGradientCaption);
begin
  inherited Create(TRxCaption);
  FParent := AParent;
end;

function TRxCaptionList.Add: TRxCaption;
begin
  Result := TRxCaption(inherited Add);
end;

function TRxCaptionList.GetCaption(Index: Integer): TRxCaption;
begin
  Result := TRxCaption(inherited Items[Index]);
end;

{$IFDEF RX_D3}
function TRxCaptionList.GetOwner: TPersistent;
begin
  Result := FParent;
end;
{$ENDIF}

procedure TRxCaptionList.RestoreDefaults;
var
  I: Integer;
begin
  BeginUpdate;
  try
    for I := 0 to Count-1 do
      Items[I].RestoreDefaults;
  finally
    EndUpdate;
  end;
end;

procedure TRxCaptionList.SetCaption(Index: Integer; Value: TRxCaption);
begin
  Items[Index].Assign(Value);
end;

procedure TRxCaptionList.Update(Item: TCollectionItem);
begin
  if (FParent <> nil) and not (csLoading in FParent.ComponentState) then
    if FParent.Active then FParent.Update;
end;

{ TRxCaption }

constructor TRxCaption.Create(Collection: TCollection);
var
  Parent: TRxGradientCaption;
begin
  Parent := nil;
  if Assigned(Collection) and (Collection is TRxCaptionList) then
    Parent := TRxCaptionList(Collection).Parent;
  try
    inherited Create(Collection);
    FFont := TFont.Create;
    if Assigned(Parent) then begin
      FFont.Assign(Parent.Font);
      FFont.Color := Parent.Font.Color;
    end
    else FFont.Color := clCaptionText;
    FFont.OnChange := FontChanged;
    FCaption := '';
    FParentFont := True;
    FVisible := True;
    FGlueNext := False;
    FInactiveColor := clInactiveCaptionText;
  finally
    if Assigned(Parent) then Changed(False);
  end;
end;

destructor TRxCaption.Destroy;
begin
  FFont.Free;
  FFont := nil;
  inherited Destroy;
end;

procedure TRxCaption.Assign(Source: TPersistent);
begin
  if Source is TRxCaption then begin
    if Assigned(Collection) then Collection.BeginUpdate;
    try
      RestoreDefaults;
      Caption := TRxCaption(Source).Caption;
      ParentFont := TRxCaption(Source).ParentFont;
      if not ParentFont then
        Font.Assign(TRxCaption(Source).Font);
      InactiveColor := TRxCaption(Source).InactiveColor;
      GlueNext := TRxCaption(Source).GlueNext;
      Visible := TRxCaption(Source).Visible;
    finally
      if Assigned(Collection) then Collection.EndUpdate;
    end;
  end
  else inherited Assign(Source);
end;

procedure TRxCaption.RestoreDefaults;
begin
  FInactiveColor := clInactiveCaptionText;
  FVisible := True;
  ParentFont := True;
end;

function TRxCaption.GetParentCaption: TRxGradientCaption;
begin
  if Assigned(Collection) and (Collection is TRxCaptionList) then
    Result := TRxCaptionList(Collection).Parent
  else
    Result := nil;
end;

procedure TRxCaption.SetCaption(const Value: string);
begin
  FCaption := Value;
  Changed(False);
end;

procedure TRxCaption.FontChanged(Sender: TObject);
begin
  FParentFont := False;
  Changed(False);
end;

procedure TRxCaption.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TRxCaption.SetParentFont(Value: Boolean);
begin
  if Value and (GradientCaption <> nil) then begin
    FFont.OnChange := nil;
    try
      FFont.Assign(GradientCaption.Font);
    finally
      FFont.OnChange := FontChanged;
    end;
  end;
  FParentFont := Value;
  Changed(False);
end;

function TRxCaption.IsFontStored: Boolean;
begin
  Result := not FParentFont;
end;

function TRxCaption.GetTextWidth: Integer;
var
  Canvas: TCanvas;
  PS: TPaintStruct;
begin
  BeginPaint(Application.Handle, PS);
  try