newtabset.pas

源代码

unit NewTabSet;

{
  Inno Setup
  Copyright (C) 1997-2004 Jordan Russell
  Portions by Martijn Laan
  For conditions of distribution and use, see LICENSE.TXT.

  TNewTabSet - modern VS.NET-style tabs

  $jrsoftware: issrc/Components/NewTabSet.pas,v 1.2 2004/12/17 03:43:54 jr Exp $
}

interface

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

type
  TNewTabSet = class(TCustomControl)
  private
    FTabs: TStrings;
    FTabIndex: Integer;
    function GetTabRect(Index: Integer): TRect;
    procedure InvalidateTab(Index: Integer);
    procedure ListChanged(Sender: TObject);
    procedure SetTabs(Value: TStrings);
    procedure SetTabIndex(Value: Integer);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property Font;
    property ParentFont;
    property TabIndex: Integer read FTabIndex write SetTabIndex;
    property Tabs: TStrings read FTabs write SetTabs;
    property OnClick;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('JR', [TNewTabSet]);
end;

{
  The RGBToHSV and HSVToRGB functions below are based on code from
  http://www.efg2.com/Lab/Graphics/Colors/HSV.htm
  which, in turn, was:
  Based on C Code in "Computer Graphics -- Principles and Practice,"
  Foley et al, 1996, p. 592.
}

procedure RGBToHSV(const R, G, B: Integer; var H, S: Double; var V: Integer);
var
  Min, Delta: Integer;
begin
  Min := R;
  if G < Min then Min := G;
  if B < Min then Min := B;
  V := R;
  if G > V then V := G;
  if B > V then V := B;

  Delta := V - Min;

  // Calculate saturation: saturation is 0 if r, g and b are all 0
  if V = 0 then
    S := 0
  else
    S := Delta / V;

  if S = 0.0 then
    H := 0     // Achromatic: When s = 0, h is undefined
  else begin   // Chromatic
    if R = V then  // between yellow and magenta [degrees]
      H := 60.0 * (G - B) / Delta
    else if G = V then  // between cyan and yellow
      H := 120.0 + 60.0 * (B - R) / Delta
    else if B = V then  // between magenta and cyan
      H := 240.0 + 60.0 * (R - G) / Delta;
    if H < 0.0 then
      H := H + 360.0;
  end;
end;

procedure HSVtoRGB(const H, S: Double; const V: Integer; var R, G, B: Integer);
var
  f: Double;
  i: Integer;
  hTemp: Double;
  p, q, t: Integer;
begin
  if S = 0.0 then begin  // color is on black-and-white center line
    R := V;  // achromatic: shades of gray
    G := V;
    B := V;
  end
  else begin  // chromatic color
    if H = 360.0 then  // 360 degrees same as 0 degrees
      hTemp := 0.0
    else
      hTemp := H;

    hTemp := hTemp / 60;  // h is now IN [0,6)
    i := Trunc(hTemp);    // largest integer <= h
    f := hTemp - i;       // fractional part of h

    p := Trunc(V * (1.0 - S));
    q := Trunc(V * (1.0 - (S * f)));
    t := Trunc(V * (1.0 - (S * (1.0 - f))));

    case i of
      0: begin R := V; G := t; B := p; end;
      1: begin R := q; G := V; B := p; end;
      2: begin R := p; G := V; B := t; end;
      3: begin R := p; G := q; B := V; end;
      4: begin R := t; G := p; B := V; end;
      5: begin R := V; G := p; B := q; end;
    else
      { Should never get here }
      R := 0;
      G := 0;
      B := 0;
    end;
  end;
end;

function LightenColor(const Color: TColorRef; const Amount: Integer): TColorRef;
var
  H, S: Double;
  V, R, G, B: Integer;
begin
  RGBtoHSV(Byte(Color), Byte(Color shr 8), Byte(Color shr 16), H, S, V);
  Inc(V, Amount);
  if V > 255 then
    V := 255;
  if V < 0 then
    V := 0;
  HSVtoRGB(H, S, V, R, G, B);
  Result := R or (G shl 8) or (B shl 16);
end;

{ TNewTabSet }

const
  TabPaddingX = 5;
  TabPaddingY = 3;
  TabSpacing = 1;

constructor TNewTabSet.Create(AOwner: TComponent);
begin
  inherited;
  FTabs := TStringList.Create;
  TStringList(FTabs).OnChange := ListChanged;
  ControlStyle := ControlStyle + [csOpaque];
  Width := 129;
  Height := 20;
end;

procedure TNewTabSet.CreateParams(var Params: TCreateParams);
begin
  inherited;
  with Params.WindowClass do
    style := style and not (CS_HREDRAW or CS_VREDRAW);
end;

destructor TNewTabSet.Destroy;
begin
  FTabs.Free;
  inherited;
end;

function TNewTabSet.GetTabRect(Index: Integer): TRect;
var
  I: Integer;
  Size: TSize;
begin
  Canvas.Font.Assign(Font);
  Result.Right := 4;
  for I := 0 to FTabs.Count-1 do begin
    Size := Canvas.TextExtent(FTabs[I]);
    Result := Bounds(Result.Right, 0, Size.cx + (TabPaddingX * 2) + TabSpacing,
      Size.cy + (TabPaddingY * 2));
    if Index = I then
      Exit;
  end;
  SetRectEmpty(Result);
end;

procedure TNewTabSet.InvalidateTab(Index: Integer);
var
  R: TRect;
begin
  if HandleAllocated and (Index >= 0) and (Index < FTabs.Count) then begin
    R := GetTabRect(Index);
    { Inc R.Right since the trailing separator of a tab overwrites the first
      pixel of the next tab }
    Inc(R.Right);
    InvalidateRect(Handle, @R, False);
  end;
end;

procedure TNewTabSet.ListChanged(Sender: TObject);
begin
  Invalidate;
end;

procedure TNewTabSet.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  I: Integer;
  R: TRect;
begin
  if Button = mbLeft then begin
    for I := 0 to FTabs.Count-1 do begin
      R := GetTabRect(I);
      if (X >= R.Left) and (X < R.Right) then begin
        TabIndex := I;
        Break;
      end;
    end;
  end;
end;

procedure TNewTabSet.Paint;
var
  HighColorMode: Boolean;

  procedure DrawTabs(const SelectedTab: Boolean);
  var
    I: Integer;
    R: TRect;
  begin
    for I := 0 to FTabs.Count-1 do begin
      R := GetTabRect(I);
      if SelectedTab and (FTabIndex = I) then begin
        Dec(R.Right, TabSpacing);
        Canvas.Brush.Color := clBtnFace;
        Canvas.FillRect(R);
        Canvas.Pen.Color := clBtnHighlight;
        Canvas.MoveTo(R.Left, R.Top);
        Canvas.LineTo(R.Left, R.Bottom-1);
        Canvas.Pen.Color := clBtnText;
        Canvas.LineTo(R.Right-1, R.Bottom-1);
        Canvas.LineTo(R.Right-1, R.Top-1);
        Canvas.Font.Color := clBtnText;
        Canvas.TextOut(R.Left + TabPaddingX, R.Top + TabPaddingY, FTabs[I]);
        ExcludeClipRect(Canvas.Handle, R.Left, R.Top, R.Right, R.Bottom);
        Break;
      end;
      if not SelectedTab and (FTabIndex <> I) then begin
        if HighColorMode and (ColorToRGB(clBtnFace) <> clBlack) then
          Canvas.Font.Color := LightenColor(ColorToRGB(clBtnShadow), -43)
        else begin
          { Like VS.NET, if the button face color is black, or if running in
            low color mode, use plain clBtnHighlight as the text color }
          Canvas.Font.Color := clBtnHighlight;
        end;
        Canvas.TextOut(R.Left + TabPaddingX, R.Top + TabPaddingY, FTabs[I]);
        if HighColorMode then
          Canvas.Pen.Color := clBtnShadow
        else
          Canvas.Pen.Color := clBtnFace;
        Canvas.MoveTo(R.Right, R.Top+3);
        Canvas.LineTo(R.Right, R.Bottom-2);
      end;
    end;
  end;

var
  CR: TRect;
begin
  Canvas.Font.Assign(Font);

  HighColorMode := (GetDeviceCaps(Canvas.Handle, BITSPIXEL) *
    GetDeviceCaps(Canvas.Handle, PLANES)) >= 15;

  CR := ClientRect;

  { Work around an apparent NT 4.0/2000/??? bug. If the width of the DC is
    greater than the width of the screen, then any call to ExcludeClipRect
    inexplicably shrinks the DC's clipping rectangle to the screen width.
    Calling IntersectClipRect first with the entire client area as the
    rectangle solves this (don't ask me why). }
  IntersectClipRect(Canvas.Handle, CR.Left, CR.Top, CR.Right, CR.Bottom);

  { Selected tab }
  DrawTabs(True);

  { Top line }
  Canvas.Pen.Color := clBtnText;
  Canvas.MoveTo(0, 0);
  Canvas.LineTo(CR.Right, 0);

  { Background fill }
  if HighColorMode then
    Canvas.Brush.Color := LightenColor(ColorToRGB(clBtnFace), 35)
  else
    Canvas.Brush.Color := clBtnShadow;
  Inc(CR.Top);
  Canvas.FillRect(CR);

  { Non-selected tabs }
  DrawTabs(False);
end;

procedure TNewTabSet.SetTabIndex(Value: Integer);
begin
  if FTabIndex <> Value then begin
    InvalidateTab(FTabIndex);
    FTabIndex := Value;
    InvalidateTab(Value);
    Click;
  end;
end;

procedure TNewTabSet.SetTabs(Value: TStrings);
begin
  FTabs.Assign(Value);
end;

end.