gr32_rangebars.pas

skin components for design of your applicastions

unit GR32_RangeBars;

(* ***** BEGIN LICENSE BLOCK *****
 * Version: MPL 1.1
 *
 * The contents of this file are subject to the Mozilla Public License Version
 * 1.1 (the "License"); you may not use this file except in compliance with
 * the License. You may obtain a copy of the License at
 * http://www.mozilla.org/MPL/
 *
 * Software distributed under the License is distributed on an "AS IS" basis,
 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
 * for the specific language governing rights and limitations under the
 * License.
 *
 * The Original Code is Graphics32
 *
 * The Initial Developer of the Original Code is
 * Alex A. Denisov
 *
 * Portions created by the Initial Developer are Copyright (C) 2000-2006
 * the Initial Developer. All Rights Reserved.
 *
 * Contributor(s):
 * Andre Beckedorf <[e-mail]>
 * Marc Lafon
 *
 * ***** END LICENSE BLOCK ***** *)

interface

{$I GR32.inc}

uses
{$IFDEF CLX}
  Qt, Types,
  {$IFDEF LINUX}Libc,{$ENDIF}
  {$IFDEF MSWINDOWS}Windows,{$ENDIF}
  QGraphics, QControls, QForms, QDialogs, QExtCtrls,
{$ELSE}
  Windows, Messages, GR32, {$IFDEF INLININGSUPPORTED}Types,{$ENDIF}
  Graphics, Controls, Forms, Dialogs, ExtCtrls,
{$ENDIF}
  SysUtils, Classes;

{$IFDEF CLX}
const
  DFCS_INACTIVE = $100;
  DFCS_PUSHED = $200;
  DFCS_FLAT = $4000;
  DFCS_SCROLLUP = 0;
  DFCS_SCROLLDOWN = 1;
  DFCS_SCROLLLEFT = 2;
  DFCS_SCROLLRIGHT = 3;
{$ENDIF}

type
  TRBDirection = (drLeft, drUp, drRight, drDown);
  TRBDirections = set of TRBDirection;
  TRBZone = (zNone, zBtnPrev, zTrackPrev, zHandle, zTrackNext, zBtnNext);
  TRBStyle = (rbsDefault, rbsMac);
  TRBBackgnd = (bgPattern, bgSolid);
  TRBGetSizeEvent = procedure(Sender: TObject; var Size: Integer) of object;

  TArrowBar = class(TCustomControl)
  private
    FBackgnd: TRBBackgnd;
    FBorderStyle: TBorderStyle;
    FButtonSize: Integer;
    FHandleColor: TColor;
    FButtoncolor:TColor;
    FHighLightColor:TColor;
    FShadowColor:TColor;
    FBorderColor:TColor;
    FKind: TScrollBarKind;
    FShowArrows: Boolean;
    FShowHandleGrip: Boolean;
    FStyle: TRBStyle;
    FOnChange: TNotifyEvent;
    FOnUserChange: TNotifyEvent;
    procedure SetButtonSize(Value: Integer);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetHandleColor(Value: TColor);
    procedure SetHighLightColor(Value: TColor);
    procedure SetShadowColor(Value: TColor);
    procedure SetButtonColor(Value: TColor);
    procedure SetBorderColor(Value: TColor);
    procedure SetKind(Value: TScrollBarKind);
    procedure SetShowArrows(Value: Boolean);
    procedure SetShowHandleGrip(Value: Boolean);
    procedure SetStyle(Value: TRBStyle);
    procedure SetBackgnd(Value: TRBBackgnd);
{$IFNDEF CLX}
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
    procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
{$ENDIF}
  protected
    GenChange: Boolean;
    DragZone: TRBZone;
    HotZone: TRBZone;
    Timer: TTimer;
    TimerMode: Integer;
    StoredX, StoredY: Integer;
    PosBeforeDrag: Single;
    procedure DoChange; virtual;
    procedure DoDrawButton(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual;
    procedure DoDrawHandle(R: TRect; Horz: Boolean; Pushed, Hot: Boolean); virtual;
    procedure DoDrawTrack(R: TRect; Direction: TRBDirection; Pushed, Enabled, Hot: Boolean); virtual;
{$IFNDEF CLX}
    procedure DrawNCArea(ADC: HDC; const Clip: HRGN); dynamic;
{$ENDIF}
    function  DrawEnabled: Boolean; virtual;
    function  GetBorderSize: Integer;
    function  GetHandleRect: TRect; virtual;
    function  GetButtonSize: Integer;
    function  GetTrackBoundary: TRect;
    function  GetZone(X, Y: Integer): TRBZone;
    function  GetZoneRect(Zone: TRBZone): TRect;
{$IFDEF CLX}
    procedure MouseLeave(AControl: TControl); override;
    procedure EnabledChanged; override;
    function WidgetFlags: Integer; override;
{$ENDIF}
    procedure MouseLeft; virtual;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
    procedure StartDragTracking;
    procedure StartHotTracking;
    procedure StopDragTracking;
    procedure StopHotTracking;
    procedure TimerHandler(Sender: TObject); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    property Color default clScrollBar;
    property Backgnd: TRBBackgnd read FBackgnd write SetBackgnd;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property ButtonSize: Integer read FButtonSize write SetButtonSize default 0;
    property HandleColor: TColor read FHandleColor write SetHandleColor default clBtnShadow;
    property ButtonColor:TColor read FButtonColor write SetButtonColor default clBtnFace;
    property HighLightColor:TColor read FHighLightColor write SetHighLightColor default clBtnHighlight;
    property ShadowColor:TColor read FShadowColor write SetShadowColor default clBtnShadow;
    property BorderColor:TColor read FBorderColor write SetBorderColor default clWindowFrame;
    property Kind: TScrollBarKind read FKind write SetKind default sbHorizontal;
    property ShowArrows: Boolean read FShowArrows write SetShowArrows default True;
    property ShowHandleGrip: Boolean read FShowHandleGrip write SetShowHandleGrip;
    property Style: TRBStyle read FStyle write SetStyle default rbsDefault;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnUserChange: TNotifyEvent read FOnUserChange write FOnUserChange;
  end;

  TRBIncrement = 1..32768;

  TCustomRangeBar = class(TArrowBar)
  private
    FCentered: Boolean;
    FEffectiveWindow: Integer;
    FIncrement: TRBIncrement;
    FPosition: Single;
    FRange: Integer;
    FWindow: Integer;
    function IsPositionStored: Boolean;
    procedure SetPosition(Value: Single);
    procedure SetRange(Value: Integer);
    procedure SetWindow(Value: Integer);
  protected
    procedure AdjustPosition;
    function  DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      {$IFDEF CLX}const{$ENDIF} MousePos: TPoint): Boolean; override;
    function  DrawEnabled: Boolean; override;
    function  GetHandleRect: TRect; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure TimerHandler(Sender: TObject); override;
    procedure UpdateEffectiveWindow;
    property EffectiveWindow: Integer read FEffectiveWindow;
  public
    constructor Create(AOwner: TComponent); override;
    procedure Resize; override;
    procedure SetParams(NewRange, NewWindow: Integer);
    property Centered: Boolean read FCentered write FCentered;
    property Increment: TRBIncrement read FIncrement write FIncrement default 8;
    property Position: Single read FPosition write SetPosition stored IsPositionStored;
    property Range: Integer read FRange write SetRange default 0;
    property Window: Integer read FWindow write SetWindow default 0;
  end;

  TRangeBar = class(TCustomRangeBar)
  published
    property Align;
    property Anchors;
    property Constraints;
    property Color;
    property Backgnd;
    property BorderStyle;
    property ButtonSize;
    property Enabled;
    property HandleColor;
    property ButtonColor;
    property HighLightColor;
    property ShadowColor;
    property BorderColor;
    property Increment;
    property Kind;
    property Range;
    property Style;
    property Visible;
    property Window;
    property ShowArrows;
    property ShowHandleGrip;
    property Position; // this should be located after the Range property
    property OnChange;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMouseWheelUp;
    property OnMouseWheelDown;
    property OnStartDrag;
    property OnUserChange;
  end;

  TCustomGaugeBar = class(TArrowBar)
  private
    FHandleSize: Integer;
    FLargeChange: Integer;
    FMax: Integer;
    FMin: Integer;
    FPosition: Integer;
    FSmallChange: Integer;
    procedure SetHandleSize(Value: Integer);
    procedure SetMax(Value: Integer);
    procedure SetMin(Value: Integer);
    procedure SetPosition(Value: Integer);
    procedure SetLargeChange(Value: Integer);
    procedure SetSmallChange(Value: Integer);
  protected
    procedure AdjustPosition;
    function  DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      {$IFDEF CLX}const{$ENDIF} MousePos: TPoint): Boolean; override;
    function  GetHandleRect: TRect; override;
    function  GetHandleSize: Integer;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure TimerHandler(Sender: TObject); override;
  public
    constructor Create(AOwner: TComponent); override;
    property HandleSize: Integer read FHandleSize write SetHandleSize default 0;
    property LargeChange: Integer read FLargeChange write SetLargeChange default 1;
    property Max: Integer read FMax write SetMax default 100;
    property Min: Integer read FMin write SetMin default 0;
    property Position: Integer read FPosition write SetPosition;
    property SmallChange: Integer read FSmallChange write SetSmallChange default 1;
    property OnChange;
    property OnUserChange;
  end;

  TGaugeBar = class(TCustomGaugeBar)
  published
    property Align;
    property Anchors;
    property Constraints;
    property Color;
    property Backgnd;
    property BorderStyle;
    property ButtonSize;
    property Enabled;
    property HandleColor;
    property ButtonColor;
    property HighLightColor;
    property ShadowColor;
    property BorderColor;
    property HandleSize;
    property Kind;
    property LargeChange;
    property Max;
    property Min;
    property ShowArrows;
    property ShowHandleGrip;
    property Style;
    property SmallChange;
    property Visible;
    property Position;
    property OnChange;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    property OnUserChange;
  end;

  { TArrowBarAccess }
  { This class is designed to facilitate access to
    properties of TArrowBar class when creating custom controls, which
    incorporate TArrowBar. It allows controlling up to two arrow bars.
    Master is used to read and write properties, slave - only to write.

    Well, maybe it is not so useful itself, but it is a common ancestor
    for TRangeBarAccess and TGaugeBarAccess classes, which work much the
    same way.

    When writing a new control, which uses TArrowBar, declare the bar as
    protected member, TArrowBarAccess as published property, and assign
    its Master to the arrow bar }
  TArrowBarAccess = class(TPersistent)
  private
    FMaster: TArrowBar;
    FSlave: TArrowBar;
    function GetBackgnd: TRBBackgnd;
    function GetButtonSize: Integer;
    function GetColor: TColor;
    function GetHandleColor: TColor;
    function GetHighLightColor: TColor;
    function GetButtonColor: TColor;
    function GetBorderColor: TColor;
    function GetShadowColor: TColor;
    function GetShowArrows: Boolean;
    function GetShowHandleGrip: Boolean;
    function GetStyle: TRBStyle;
    procedure SetBackgnd(Value: TRBBackgnd);
    procedure SetButtonSize(Value: Integer);
    procedure SetColor(Value: TColor);
    procedure SetHandleColor(Value: TColor);
    procedure SetShowArrows(Value: Boolean);
    procedure SetShowHandleGrip(Value: Boolean);
    procedure SetStyle(Value: TRBStyle);
    procedure SetHighLightColor(Value: TColor);
    procedure SetShadowColor(Value: TColor);
    procedure SetButtonColor(Value: TColor);
    procedure SetBorderColor(Value: TColor);
  public
    property Master: TArrowBar read FMaster write FMaster;
    property Slave: TArrowBar read FSlave write FSlave;
  published
    property Color: TColor read GetColor write SetColor default clScrollBar;
    property Backgnd: TRBBackgnd read GetBackgnd write SetBackgnd default bgPattern;
    property ButtonSize: Integer read GetButtonSize write SetButtonSize default 0;
    property HandleColor: TColor read GetHandleColor write SetHandleColor default clBtnShadow;
    property ButtonColor:TColor read GetButtonColor write SetButtonColor default clBtnFace;
    property HighLightColor:TColor read GetHighLightColor write SetHighLightColor default clBtnHighlight;
    property ShadowColor:TColor read GetShadowColor write SetShadowColor default clBtnShadow;
    property BorderColor:TColor read GetBorderColor write SetBorderColor default clWindowFrame;
    property ShowArrows: Boolean read GetShowArrows write SetShowArrows default True;
    property ShowHandleGrip: Boolean read GetShowHandleGrip write SetShowHandleGrip;
    property Style: TRBStyle read GetStyle write SetStyle;
  end;

implementation

uses Math, GR32_System;

const
  OppositeDirection: array [TRBDirection] of TRBDirection = (drRight, drDown, drLeft, drUp);
  tmScrollFirst = 1;
  tmScroll = 2;
  tmHotTrack = 3;

function ClrLighten(C: TColor; Amount: Integer): TColor;
var
  R, G, B: Integer;
begin
{$IFDEF CLX}
  C := ColorToRGB(C);
{$ELSE}
  if C < 0 then C := GetSysColor(C and $000000FF);
{$ENDIF}
  R := C and $FF + Amount;
  G := C shr 8 and $FF + Amount;
  B := C shr 16 and $FF + Amount;
  if R < 0 then R := 0 else if R > 255 then R := 255;
  if G < 0 then G := 0 else if G > 255 then G := 255;
  if B < 0 then B := 0 else if B > 255 then B := 255;
  Result := R or (G shl 8) or (B shl 16);
end;

function MixColors(C1, C2: TColor; W1: Integer): TColor;
var
  W2: Cardinal;
begin
  Assert(W1 in [0..255]);
  W2 := W1 xor 255;
{$IFDEF CLX}
  C1 := ColorToRGB(C1);
  C2 := ColorToRGB(C2);
{$ELSE}
  if Integer(C1) < 0 then C1 := GetSysColor(C1 and $000000FF);
  if Integer(C2) < 0 then C2 := GetSysColor(C2 and $000000FF);
{$ENDIF}
  Result := Integer(
    ((Cardinal(C1) and $FF00FF) * Cardinal(W1) +
    (Cardinal(C2) and $FF00FF) * W2) and $FF00FF00 +
    ((Cardinal(C1) and $00FF00) * Cardinal(W1) +
    (Cardinal(C2) and $00FF00) * W2) and $00FF0000) shr 8;
end;

procedure DitherRect(Canvas: TCanvas; const R: TRect; C1, C2: TColor);
var
  B: TBitmap;
{$IFNDEF CLX}
  Brush: HBRUSH;
{$ELSE}
  Brush: TBrush;
  OldBrush: TBrush;
{$ENDIF}
begin
  if IsRectEmpty(R) then Exit;
{$IFDEF CLX}
  Brush := TBrush.Create;
  if C1 = C2 then
  begin
    Brush.Color := ColorToRGB(C1);
  end
  else
  begin
    B := AllocPatternBitmap(C1, C2);
    Brush.Bitmap := B;
  end;
  OldBrush := TBrush.Create;
  OldBrush.Assign(Canvas.Brush);
  Canvas.Brush.Assign(Brush);
  Canvas.FillRect(R);
  Canvas.Brush.Assign(OldBrush);
  Brush.Free;
  OldBrush.Free;
{$ELSE}
  if C1 = C2 then
    Brush := CreateSolidBrush(ColorToRGB(C1))
  else
  begin
    B := AllocPatternBitmap(C1, C2);
    B.HandleType := bmDDB;
    Brush := CreatePatternBrush(B.Handle);
  end;
  FillRect(Canvas.Handle, R, Brush);
  DeleteObject(Brush);
{$ENDIF}
end;

procedure DrawRectEx(Canvas: TCanvas; var R: TRect; Sides: TRBDirections; C: TColor);
begin
  if Sides <> [] then with Canvas, R do
  begin
    Pen.Color := C;
    if drUp in Sides then
    begin
      MoveTo(Left, Top); LineTo(Right, Top); Inc(Top);
    end;
    if drDown in Sides then
    begin
      Dec(Bottom); MoveTo(Left, Bottom); LineTo(Right, Bottom);
    end;
    if drLeft in Sides then
    begin
      MoveTo(Left, Top); LineTo(Left, Bottom); Inc(Left);
    end;
    if drRight in Sides then
    begin
      Dec(Right); MoveTo(Right, Top); LineTo(Right, Bottom);
    end;
  end;
end;

{$IFDEF CLX}
procedure FrameRect(Canvas: TCanvas; const R: TRect);
begin
  with Canvas, R do
    Rectangle(Left, Top, Right, Bottom);
end;
{$ENDIF}

procedure Frame3D(Canvas: TCanvas; var ARect: TRect; TopColor, BottomColor: TColor; AdjustRect: Boolean = True);
var