fthtabs.pas

Gestione Cellulari Nokia

{*******************************************************}
{                                                       }
{       4th GUI Library for Delphi                      }
{       FourthTabSet Unit                               }
{                                                       }
{       Copyright (C) 1996,2001 Sergey S. Tkachenko     }
{       e-mail: [e-mail]                    }
{          Web: www.4thfebruary.f2s.com                 }
{                                                       }
{       Based on the TTabSet component                  }
{       Copyright (C) Borland Software Corporation      }
{                                                       }
{*******************************************************}

unit FthTabs;

{$I FTHVER.INC}

interface

uses Windows, Classes, Graphics, Forms, Controls, Messages;

type
  TScrollBtn = (sbLeft, sbRight);

  TFourthScroller = class(TCustomControl)
  private
    FMin: Longint;
    FMax: Longint;
    FPosition: Longint;
    FOnClick: TNotifyEvent;
    FChange: Integer;
    Bitmap: TBitmap;
    Pressed: Boolean;
    Down: Boolean;
    Current: TScrollBtn;
    pWidth: Integer;
    pHeight: Integer;
    procedure SetMin(Value: Longint);
    procedure SetMax(Value: Longint);
    procedure SetPosition(Value: Longint);
    function CanScrollLeft: Boolean;
    function CanScrollRight: Boolean;
    procedure DoMouseDown(X: Integer);
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
  published
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property Min: Longint read FMin write SetMin default 0;
    property Max: Longint read FMax write SetMax default 0;
    property Position: Longint read FPosition write SetPosition default 0;
    property Change: Integer read FChange write FChange default 1;
  end;

  TFourthTabSet = class;

  TFourthTabList = class(TStringList)
  private
    Tabs: TFourthTabSet;
  public
    procedure Insert(Index: Integer; const S: string); override;
    procedure Delete(Index: Integer); override;
    function Add(const S: string): Integer; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure Clear; override;
    procedure AddStrings(Strings: TStrings); override;
  end;

  TFourthTabSetFlatStyle = (fsNoFlat, fsMiddleFlat, fsFullFlat);

  TFourthTabSetOptions = class(TPersistent)
  private
    FBGColor: TColor;
    FFlatStyle: TFourthTabSetFlatStyle;
    FOnChange: TNotifyEvent;
    FSeparatorColor: TColor;
    FUnSelColor: TColor;
    FLightColor: TColor;
    FHighlightColor: TColor;
    FShadowColor: TColor;
    FDarkShadowColor: TColor;
    FFaceColor: TColor;
    procedure SetBGColor(Value: TColor);
    procedure SetFlatStyle(Value: TFourthTabSetFlatStyle);
    procedure SetSeparatorColor(Value: TColor);
    procedure SetUnselectedColor(Value: TColor);
    procedure SetLightColor(Value: TColor);
    procedure SetHighlightColor(Value: TColor);
    procedure SetShadowColor(Value: TColor);
    procedure SetDarkShadowColor(Value: TColor);
    procedure SetFaceColor(Value: TColor);
  protected
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  public
    constructor Create;
  published
    property BackgroundColor: TColor read FBGColor write SetBGColor
      default clBtnShadow;
    property LightColor: TColor read FLightColor write SetLightColor
      default cl3DLight;
    property HighlightColor: TColor read FHighlightColor write SetHighlightColor
      default clBtnHighlight;
    property ShadowColor: TColor read FShadowColor write SetShadowColor
      default clBtnShadow;
    property DarkShadowColor: TColor read FDarkShadowColor write
      SetDarkShadowColor default cl3DDkShadow;
    property FlatStyle: TFourthTabSetFlatStyle read FFlatStyle write SetFlatStyle default fsMiddleFlat;
    property SeparatorColor: TColor read FSeparatorColor write SetSeparatorColor
      default clBtnFace;
    property UnselectedColor: TColor read FUnSelColor write SetUnselectedColor
      default clBtnHighlight;
    property FaceColor: TColor read FFaceColor write SetFaceColor default
      clBtnFace;
  end;

  TEdgePart = (epSelectedLeft, epUnselectedLeft, epSelectedRight,
    epUnselectedRight);

  TEdgeType = (etNone, etFirstIsSel, etFirstNotSel, etLastIsSel, etLastNotSel,
    etNotSelToSel, etSelToNotSel, etNotSelToNotSel);

  TTabStyle = (tsStandard, tsOwnerDraw);

  TMeasureTabEvent = procedure(Sender: TObject; Index: Integer;
    var TabWidth: Integer) of object;
  TDrawTabEvent = procedure(Sender: TObject; TabCanvas: TCanvas; R: TRect;
    Index: Integer; Selected: Boolean) of object;
  TTabChangeEvent = procedure(Sender: TObject; NewTab: Integer;
    var AllowChange: Boolean) of object;

  TFourthTabSet = class(TCustomControl)
  private
    FOptions: TFourthTabSetOptions;
    FStartMargin: Integer;
    FEndMargin: Integer;
    FTabs: TStrings;
    FTabIndex: Integer;
    FFirstIndex: Integer;
    FVisibleTabs: Integer;
    FAutoScroll: Boolean;
    FStyle: TTabStyle;
    FOwnerDrawHeight: Integer;
    FOnMeasureTab: TMeasureTabEvent;
    FOnDrawTab: TDrawTabEvent;
    FOnChange: TTabChangeEvent;
    TabPositions: TList;
    FTabHeight: Integer;
    FTopEdge, FBottomEdge: integer;
    FScroller: TFourthScroller;
    FDoFix: Boolean;
    FDisabledTabs: TStrings;
    procedure SetAutoScroll(Value: Boolean);
    procedure SetStartMargin(Value: Integer);
    procedure SetEndMargin(Value: Integer);
    procedure SetTabIndex(Value: Integer);
    procedure SetFirstIndex(Value: Integer);
    procedure SetTabList(Value: TStrings);
    procedure SetTabStyle(Value: TTabStyle);
    procedure SetTabHeight(Value: Integer);
    procedure SetDisabledTabList(const Value: TStrings);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    function CalcTabPositions(Start, Stop: Integer; Canvas: TCanvas;
      First: Integer): Integer;
    procedure CreateScroller;
    procedure FixTabPos;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure ScrollClick(Sender: TObject);
    procedure ReadIntData(Reader: TReader);
    procedure ReadBoolData(Reader: TReader);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X,
      Y: Integer); override;
    procedure Paint; override;
    procedure DrawTab(TabCanvas: TCanvas; R: TRect; Index: Integer;
      Selected: Boolean); virtual;
    function CanChange(NewIndex: Integer): Boolean;
    procedure GetChildren(Proc: TGetChildProc{$IFDEF DELPHI3_UP}; Root: TComponent{$ENDIF}); override;
    procedure MeasureTab(Index: Integer; var TabWidth: Integer); virtual;
    procedure DefineProperties(Filer: TFiler); override;
    function TabEnabled(index:integer): Boolean;
    procedure OptionsChange(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ItemAtPos(Pos: TPoint): Integer;
    function ItemRect(Item: Integer): TRect;
    procedure SelectNext(Direction: Boolean);
    property Canvas;
    property FirstIndex: Integer read FFirstIndex write SetFirstIndex default 0;
  published
    property Align;
{$IFDEF FCL_D4}
    property Anchors;
{$ENDIF}
    property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default True;
{$IFDEF FCL_D4}
    property Constraints;
{$ENDIF}
    property DragCursor;
{$IFDEF FCL_D4}
    property DragKind;
{$ENDIF}
    property DragMode;
    property Enabled;
    property DisabledTabs: TStrings read FDisabledTabs write SetDisabledTabList;
    property EndMargin: Integer read FEndMargin write SetEndMargin default 5;
    property Font;
    property Options: TFourthTabSetOptions read FOptions write FOptions;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property StartMargin: Integer read FStartMargin write SetStartMargin default 5;
    property Style: TTabStyle read FStyle write SetTabStyle default tsStandard;
    property TabHeight: Integer read FOwnerDrawHeight write SetTabHeight default 20;
    property Tabs: TStrings read FTabs write SetTabList;
    property TabIndex: Integer read FTabIndex write SetTabIndex default -1;
    property Visible;
    property VisibleTabs: Integer read FVisibleTabs;
    property OnClick;
    property OnChange: TTabChangeEvent read FOnChange write FOnChange;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawTab: TDrawTabEvent read FOnDrawTab write FOnDrawTab;
{$IFDEF FCL_D4}
    property OnEndDock;
{$ENDIF}
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnMeasureTab: TMeasureTabEvent read FOnMeasureTab write FOnMeasureTab;
{$IFDEF FCL_D4}
    property OnStartDock;
{$ENDIF}
    property OnStartDrag;
  end;

implementation

uses Consts, SysUtils;

{$R FthTabs}

const
  EdgeWidth = 9;

type
  TTabPos = record
    Size, StartPos: Word;
  end;

{ TFourthScroller }

constructor TFourthScroller.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  Bitmap := TBitmap.Create;
  pWidth := 24;
  pHeight := 12;
  FMin := 0;
  FMax := 0;
  FPosition := 0;
  FChange := 1;
end;

destructor TFourthScroller.Destroy;
begin
  Bitmap.Free;
  inherited Destroy;
end;

procedure TFourthScroller.Paint;
begin
  with Canvas do
  begin
    { paint left button }
    if CanScrollLeft then
    begin
      if Down and (Current = sbLeft) then
{$IFDEF FCL_D3}
        Bitmap.Handle := CreateGrayMappedRes(HInstance, 'FTHSBLEFTDN') else
        Bitmap.Handle := CreateGrayMappedRes(HInstance, 'FTHSBLEFT');
{$ELSE}
        Bitmap.Handle := LoadBitmap(HInstance, 'FTHSBLEFTDN') else
        Bitmap.Handle := LoadBitmap(HInstance, 'FTHSBLEFT');
{$ENDIF}
    end else
{$IFDEF FCL_D3}
      Bitmap.Handle := CreateGrayMappedRes(HInstance, 'FTHSBLEFTDIS');
{$ELSE}
      Bitmap.Handle := LoadBitmap(HInstance, 'FTHSBLEFTDIS');
{$ENDIF}
    Draw(0, 0, Bitmap);

    { paint right button }
    if CanScrollRight then
    begin
      if Down and (Current = sbRight) then
{$IFDEF FCL_D3}
        Bitmap.Handle := CreateGrayMappedRes(HInstance, 'FTHSBRIGHTDN') else
        Bitmap.Handle := CreateGrayMappedRes(HInstance, 'FTHSBRIGHT');
{$ELSE}
        Bitmap.Handle := LoadBitmap(HInstance, 'FTHSBRIGHTDN') else
        Bitmap.Handle := LoadBitmap(HInstance, 'FTHSBRIGHT');
{$ENDIF}
    end else
{$IFDEF FCL_D3}
      Bitmap.Handle := CreateGrayMappedRes(HInstance, 'FTHSBRIGHTDIS');
{$ELSE}
      Bitmap.Handle := LoadBitmap(HInstance, 'FTHSBRIGHTDIS');
{$ENDIF}
    Draw((pWidth div 2), 0, Bitmap);
  end;
end;

procedure TFourthScroller.WMSize(var Message: TWMSize);
begin
  inherited;
  Width := pWidth;
  Height := pHeight;
end;

procedure TFourthScroller.SetMin(Value: Longint);
begin
  if Value < FMax then FMin := Value;
end;

procedure TFourthScroller.SetMax(Value: Longint);
begin
  if Value > FMin then FMax := Value;
end;

procedure TFourthScroller.SetPosition(Value: Longint);
begin
  if Value <> FPosition then
  begin
    if Value < Min then Value := Min;
    if Value > Max then Value := Max;
    FPosition := Value;
    Invalidate;
    if Assigned(FOnClick) then
      FOnClick(Self);
  end;
end;

function TFourthScroller.CanScrollLeft: Boolean;
begin
  Result := Position > Min;
end;

function TFourthScroller.CanScrollRight: Boolean;
begin
  Result := Position < Max;
end;

procedure TFourthScroller.DoMouseDown(X: Integer);
begin
  if X < pWidth div 2 then
    Current := sbLeft else
    Current := sbRight;
  case Current of
    sbLeft:  if not CanScrollLeft then Exit;
    sbRight: if not CanScrollRight then Exit;
  end;
  Pressed := True;
  Down := True;
  Invalidate;
  SetCapture(Handle);
end;

procedure TFourthScroller.WMLButtonDown(var Message: TWMLButtonDown);
begin
  DoMouseDown(Message.XPos);
end;

procedure TFourthScroller.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  DoMouseDown(Message.XPos);
end;

procedure TFourthScroller.WMMouseMove(var Message: TWMMouseMove);
var
  P: TPoint;
  R: TRect;
begin
  if Pressed then
  begin
    P := Point(Message.XPos, Message.YPos);
    R := Rect(0, 0, pWidth div 2, pHeight);
    if Current = sbRight then OffsetRect(R, pWidth div 2, 0);
    if PtInRect(R, P) <> Down then
    begin
      Down := not Down;
      Invalidate;
    end;
  end;
end;

procedure TFourthScroller.WMLButtonUp(var Message: TWMLButtonUp);
var
  NewPos: Longint;
begin