Chip 2003 November/Chip_2003-11_cd1.bin/program/delphi/kompon/DIHtmlLabel.exe/Demos/DIHtmlLabel/CategCh.pas

Pascal/Delphi Source File | 2003-01-24 | 9.1 KB | 329 lines

{-----------------------------------------------------------------------------
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 expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: CategCh.pas, released 2002-01-06.

The Initial Developer of the Original Code is David Polberger <[e-mail]>
Portions created by David Polberger are Copyright (C) 2002 David Polberger.
All Rights Reserved.

Contributor(s): ______________________________________.

Last Modified: 2002-01-06;
Current Version: 1.00

You may retrieve the latest version of this file at the Project JEDI home page,
located at http://www.delphi-jedi.org

Known Issues:
  None.
Description:
  TCategoryChooser displays an attractive list of categories that users can
  choose from. TJvLinkLabel's demo project makes use of this component, by
  creating instances of it at run-time.

  It is not intended to be a part of the JEDI VCL, as it does one specific thing
  well, but not much else. Having said that, it's licened under the MPL license,
  just like TJvLinkLabel, so you're free to use it in your own projects, if you
  like. Simply add it to the package of your choice, and install it into the
  IDE.
-----------------------------------------------------------------------------}

unit CategCh;

interface

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

type
  TCategoryChooser = class(TGraphicControl)
  private
    FCatList: TStringList;
    FBackgroundColor: TColor;
    FActiveColor: TColor;
    FCatHeight: Integer;
    FActiveCat: Integer;
    FSelectedCat: Integer;
    FLastOutOfBounds: Boolean;

    FCatChange: TNotifyEvent;
    procedure SetCatList(const Value: TStringList);
    function GetLineColor: TColor;
    procedure SetLineColor(const Value: TColor);
    function IsCursorWithinBounds: Boolean;
    procedure DrawCat(Index: Integer; Color: TColor);
    function GetCatAtPos(y: Integer): Integer;
    procedure MouseLeave;
    procedure SetBackgroundColor(const Value: TColor);
    procedure SetActiveColor(const Value: TColor);
    procedure SetCatHeight(const Value: Integer);
    procedure SetSelectedCat(const Value: Integer);
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  protected
    procedure Paint; override;
    procedure MouseMove(Shift: TShiftState; x, y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; x, y: Integer); override;
    procedure DoCatChange; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property ActiveCat: Integer read FActiveCat;
    property Canvas;
  published
    property CatList: TStringList read FCatList write SetCatList;
    property BackgroundColor: TColor read FBackgroundColor write SetBackgroundColor;
    property ActiveColor: TColor read FActiveColor write SetActiveColor;
    property LineColor: TColor read GetLineColor write SetLineColor;
    property Font;
    property ParentFont;
    property CatHeight: Integer read FCatHeight write SetCatHeight;
    property SelectedCat: Integer read FSelectedCat write SetSelectedCat;
    property OnCatChange: TNotifyEvent read FCatChange write FCatChange;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('The Delphi Inspiration', [TCategoryChooser]);
end;

{ TCategoryChooser }

constructor TCategoryChooser.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCatList := TStringList.Create;

  // Set default values
  FBackgroundColor := $00F0CAA6;
  FActiveColor := clWhite;
  FCatHeight := 24;
  FSelectedCat := 0;
  FLastOutOfBounds := False;

  Width := 100;
  Height := 200;
end;

{ ---------------------------------------------------------------------------- }

destructor TCategoryChooser.Destroy;
begin
  inherited Destroy;
  FCatList.Free;
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  MouseLeave;
end;

{ ---------------------------------------------------------------------------- }

function TCategoryChooser.IsCursorWithinBounds: Boolean;
var
  p: TPoint;
begin
  p := ScreenToClient(Mouse.CursorPos);
  Result :=
    (p.x >= 0) and (p.x <= Width) and
    (p.y >= 0) and (p.y <= FCatList.Count * FCatHeight - 1);
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.DoCatChange;
begin
  if Assigned(FCatChange) then FCatChange(Self);
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.DrawCat(Index: Integer; Color: TColor);

  function ValueToAddToTop: Integer;
  begin
    { The first category does not have a line drawn at the top; thus we fill
      the entire rectangle in this case. }
    if Index = 0 then
      Result := 0
    else
      Result := 1;
  end;

begin
  if (Index >= 0) and (Index < FCatList.Count) then
    with Canvas do
      begin
        Brush.Color := Color;
        FillRect(Rect(0, Index * FCatHeight + ValueToAddToTop, Width,
          (Index + 1) * FCatHeight));

        TextOut(4, (FCatHeight div 2 - (Abs(Font.Height) div 2)) +
          Index * FCatHeight - 2, FCatList[Index]);

        MoveTo(0, (Index + 1) * FCatHeight);
        LineTo(Width + 1, (Index + 1) * FCatHeight);
      end;
end;

{ ---------------------------------------------------------------------------- }

function TCategoryChooser.GetCatAtPos(y: Integer): Integer;
begin
  Result := y div FCatHeight;
  if Result >= FCatList.Count then
    Result := -1;
end;

{ ---------------------------------------------------------------------------- }

function TCategoryChooser.GetLineColor: TColor;
begin
  Result := Canvas.Pen.Color;
end;

procedure TCategoryChooser.MouseLeave;
begin
  DrawCat(FActiveCat, FBackgroundColor);
  FActiveCat := FSelectedCat;
  DrawCat(FActiveCat, FActiveColor);
end;

procedure TCategoryChooser.MouseMove(Shift: TShiftState; x, y: Integer);
var
  CatIndex: Integer;
begin
  inherited MouseMove(Shift, x, y);

  if IsCursorWithinBounds then
    Cursor := crHandPoint
  else
    Cursor := crDefault;

  CatIndex := GetCatAtPos(y);

  if CatIndex <> FActiveCat then
    if IsCursorWithinBounds then
      begin
        // Let's remove the highlight from the last active category
        DrawCat(FActiveCat, FBackgroundColor);

        FActiveCat := CatIndex;
        DrawCat(FActiveCat, FActiveColor);
      end else
      if not FLastOutOfBounds then MouseLeave;

  FLastOutOfBounds := not IsCursorWithinBounds;
end;

procedure TCategoryChooser.MouseUp(Button: TMouseButton;
  Shift: TShiftState; x, y: Integer);
var
  OldSelectedCat: Integer;
begin
  inherited MouseUp(Button, Shift, x, y);

  if GetCatAtPos(y) <> -1 then
    begin
      OldSelectedCat := FSelectedCat;
      FSelectedCat := GetCatAtPos(y);

      if OldSelectedCat <> FSelectedCat then
        DoCatChange;
    end;
end;

procedure TCategoryChooser.Paint;
var
  i: Integer;

  function GetColor: TColor;
  begin
    if i = FActiveCat then
      Result := FActiveColor
    else
      Result := FBackgroundColor;
  end;

begin
  // inherited Paint; // Does nothing anyway.

  with Canvas do
    begin
      Font := Self.Font;
      Brush.Color := FBackgroundColor;
      FillRect(Rect(0, 0, Width, Height));

      for i := 0 to FCatList.Count - 1 do
        DrawCat(i, GetColor);
    end;
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.SetActiveColor(const Value: TColor);
begin
  FActiveColor := Value;
  Paint;
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.SetBackgroundColor(const Value: TColor);
begin
  FBackgroundColor := Value;
  Paint;
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.SetCatHeight(const Value: Integer);
begin
  FCatHeight := Value;
  Paint;
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.SetCatList(const Value: TStringList);
begin
  FCatList.Assign(Value);
  Paint;
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.SetLineColor(const Value: TColor);
begin
  Canvas.Pen.Color := Value;
end;

{ ---------------------------------------------------------------------------- }

procedure TCategoryChooser.SetSelectedCat(const Value: Integer);
begin
  FSelectedCat := Value;
  FActiveCat := Value;

  DoCatChange;
  Paint;
end;

end.