Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE21/COLORBUT/COLORBUT.ZIP/ColorButton.pas

Pascal/Delphi Source File | 1997-02-26 | 17.5 KB | 600 lines

unit ColorButton;

///////////////////////////////////////////////////////////////////////////////
//                                                                           //
//        ///////////////////////////////////////////////////////////        //
//        //                                                       //        //
//        //               ColorButton Component 3.0               //        //
//        //                for Borland Delphi 2.xx                //        //
//        //                                                       //        //
//        //      Written by  Jonathan Grant and Peter Steele      //        //
//        //     Copyright ⌐ 1995-1997 Information Expressions     //        //
//        //                                                       //        //
//        ///////////////////////////////////////////////////////////        //
//                                                                           //
//      Improvements/enhancements in version 3.0...                          //
//                                                                           //
//         1. Capabitity for multi-line text.                                //
//         2. Raised/lowered text styles.                                    //
//         3. Button can be 'multi-state'.                                   //
//                                                                           //
///////////////////////////////////////////////////////////////////////////////

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls, Buttons;

type
  TAlignment = (alTopLeft, alTopCenter, alTopRight,
                alMiddleLeft, alMiddleCenter, alMiddleRight,
                alBottomLeft, alBottomCenter, alBottomRight);

  TButtonBevel = (bbLowered, bbNone, bbRaised);

  TFontStyle   = (fnNormal, fnRaised, fnLowered);

  TButtonStyles = (bsAutoSize, bsCenter, bsStretch, bsShowFocus, bsSpeedKey, bsMultiState, bsMultiLine);
  TButtonStyle = set of TButtonStyles;

  TButtonState = (bsUp, bsDown, bsDisabled);

  TColorButton = class(TCustomControl)
  private
    FAlignment:       TAlignment;
    FBevelStyle:      TButtonBevel;
    FBevelSize:       Integer;

    FColor:           TColor;
    FShadowColor:     TColor;
    FHighlightColor:  TColor;

    FPicture:         TPicture;
    FSpacing:         Integer;
    FStyle:           TButtonStyle;
    FFontStyle:       TFontStyle;

    FFocused:         Boolean;
    FState:           TButtonState;

    procedure SetAlignment(Value: TAlignment);
    procedure SetBevelStyle(Value: TButtonBevel);
    procedure SetBevelSize(Value: Integer);
    procedure SetCaption(var Message: TMessage); message CM_TEXTCHANGED;
    procedure SetColor(Value: TColor);
    procedure SetEnabled(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure SetFocusOff(var Message: TMessage); message CM_LOSTFOCUS;
    procedure SetFocusOn(var Message: TMessage); message CM_GOTFOCUS;
    procedure SetFont(var Message: TMessage); message CM_FONTCHANGED;
    procedure SetFontStyle(Value: TFontStyle);
    procedure SetPicture(Value: TPicture);
    procedure SetSize(var Message: TMessage); message WM_SIZE;
    procedure SetSpacing(Value: Integer);
    procedure SetStyle(Value: TButtonStyle);

    function  GetValue: Boolean;
    procedure SetValue(Value: Boolean);

    procedure DoEnter; override;
    procedure DoExit; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure KeyAccel(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
    procedure Paint; override;
  published
    property Alignment: TAlignment read FAlignment write SetAlignment default alMiddleCenter;
    property BevelStyle: TButtonBevel read FBevelStyle write SetBevelStyle default bbRaised;
    property BevelSize: Integer read FBevelSize write SetBevelSize default 2;
    property Caption;
    property Color: TColor read FColor write SetColor default clBtnFace;
    property Cursor;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property FontStyle: TFontStyle read FFontStyle write SetFontStyle;
    property Height;
    property Left;
    property Name;
    property Picture: TPicture read FPicture write SetPicture;
    property Spacing: Integer read FSpacing write SetSpacing default 2;
    property Style: TButtonStyle read FStyle write SetStyle default [bsCenter, bsShowFocus, bsSpeedKey, bsMultiLine];
    property Tag;
    property TabOrder;
    property TabStop;
    property Top;
    property Value: Boolean read GetValue write SetValue default False;
    property Width;

    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
  end;

procedure Register;

function Smallest(X, Y: Integer): Integer;
function Largest(X, Y: Integer): Integer;

function GetHighlightColor(BaseColor: TColor): TColor;
function GetShadowColor(BaseColor: TColor): TColor;


implementation

procedure Register;
begin
  RegisterComponents('Extra', [TColorButton]);
end;

//
// Global procedures and functions
///////////////////////////////////////////////////////////////////////////////

function Smallest(X, Y: Integer): Integer;
begin
    if (X < Y) then Result := X else Result := Y;
end;

function Largest(X, Y: Integer): Integer;
begin
    if (X > Y) then Result := X else Result := Y;
end;

function GetHighlightColor(BaseColor: TColor): TColor;
begin
    Result := RGB(
      Smallest(GetRValue(ColorToRGB(BaseColor)) + 64, 255),
    Smallest(GetGValue(ColorToRGB(BaseColor)) + 64, 255),
    Smallest(GetBValue(ColorToRGB(BaseColor)) + 64, 255)
      );
end;

function GetShadowColor(BaseColor: TColor): TColor;
begin
    Result := RGB(
      Largest(GetRValue(ColorToRGB(BaseColor)) - 64, 0),
    Largest(GetGValue(ColorToRGB(BaseColor)) - 64, 0),
    Largest(GetBValue(ColorToRGB(BaseColor)) - 64, 0)
      );
end;

//
// ColorButton procedures and functions
///////////////////////////////////////////////////////////////////////////////

constructor TColorButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FAlignment  := alMiddleCenter;
  FBevelStyle := bbRaised;
  FBevelSize  := 2;
  FSpacing    := 2;
  FStyle      := [bsCenter, bsShowFocus, bsSpeedKey, bsMultiLine];
  FFontStyle  := fnNormal;

  FColor          := clBtnFace;
  FShadowColor    := clBtnShadow;
  FHighlightColor := clBtnHighlight;

  FPicture     := TPicture.Create;

  FFocused     := False;
  FState       := bsUp;

  Width       := 75;
  Height      := 25;
  Enabled     := True;
  TabStop     := True;
end;

destructor TColorButton.Destroy;
begin
  FPicture.Free;

  inherited Destroy;
end;

procedure TColorButton.Loaded;
begin
  inherited Loaded;

  if Enabled then FState := bsUp else FState := bsDisabled;

  FShadowColor    := GetShadowColor(FColor);
  FHighlightColor := GetHighlightColor(FColor);

  Repaint;
end;

procedure TColorButton.Paint;

  procedure DrawCaption(xOffset, yOffset: Integer);
  var
    Buffer: array[0..255] of Char;
    DrawRect: TRect;
    DrawTop, DrawHeight: Integer;
    DrawOptions: Integer;
  begin
    StrPCopy(Buffer, Caption);

    // Figure out drawing options
    if (bsMultiLine in FStyle) then DrawOptions := DT_WORDBREAK else DrawOptions := DT_SINGLELINE;
    if not (bsSpeedKey in FStyle) then Inc(DrawOptions, DT_NOPREFIX);
    case FAlignment of
      alTopLeft,   alMiddleLeft,   alBottomLeft  : Inc(DrawOptions, DT_LEFT);
      alTopCenter, alMiddleCenter, alBottomCenter: Inc(DrawOptions, DT_CENTER);
      alTopRight,  alMiddleRight,  alBottomRight : Inc(DrawOptions, DT_RIGHT);
    end;

    // Calculate text height
    DrawRect := Rect(FBevelSize + FSpacing, FBevelSize + FSpacing, Width - (FBevelSize + FSpacing), Height - (FBevelSize + FSpacing));
    DrawHeight := DrawText(Canvas.Handle, Buffer, Length(Caption), DrawRect, DrawOptions + DT_CALCRECT);

    // Calculate text drawing position (vertical)
    DrawRect := Rect(FBevelSize + FSpacing, FBevelSize + FSpacing, Width - (FBevelSize + FSpacing), Height - (FBevelSize + FSpacing));
    case FAlignment of
      alTopLeft,    alTopCenter,    alTopRight   : DrawTop := DrawRect.Top;
      alMiddleLeft, alMiddleCenter, alMiddleRight: DrawTop := ((Height - FBevelSize) - DrawHeight) div 2;
      alBottomLeft, alBottomCenter, alBottomRight: DrawTop := DrawRect.Bottom - DrawHeight;
    end;
    DrawRect := Rect(DrawRect.Left, DrawTop, DrawRect.Right, DrawTop + DrawHeight);

    // Offset the text if button is pressed
    // if (FState = bsDown) then begin
    //   if (FBevelStyle = bbRaised) then OffsetRect(DrawRect, FBevelSize, FBevelSize);
    //   if (FBevelStyle = bbLowered) then OffsetRect(DrawRect, -FBevelSize, -FBevelSize);
    // end;

    OffsetRect(DrawRect, xOffset, yOffset);

    // Draw the text
    DrawText(Canvas.Handle, Buffer, Length(Caption), DrawRect, DrawOptions);
  end;


var
  Client, Picture: TRect;
  FontBase: TColor;
begin
    if not Enabled and not (csDesigning in ComponentState) then FState := bsDisabled
  else if FState = bsDisabled then FState := bsUp;

    if ((not (FPicture.Graphic = nil)) and (bsAutoSize in FStyle)) then begin
    Width := FPicture.Width + (FBevelSize * 2);
    Height := FPicture.Height + (FBevelSize * 2);
  end;

  Client := Bounds(0, 0, Width, Height);
  Canvas.Font.Assign(Font);

  with inherited Canvas do begin
    // Clear the background
    Brush.Color := FColor;

    FillRect(Client);
    // Draw the button bevel
    if not (FBevelStyle = bbNone) then begin
      if ((FState = bsDown) xor (FBevelStyle = bbLowered)) then
          Frame3D(Canvas, Client, FShadowColor, FHighlightColor, FBevelSize)
      else
          Frame3D(Canvas, Client, FHighLightColor, FShadowColor, FBevelSize);
    end;

    // Draw the focus
    if (FFocused and (bsShowFocus in FStyle)) and Enabled then
        DrawFocusRect(Rect(Client.Left + FSpacing - 1, Client.Top + FSpacing - 1,
        Client.Right - FSpacing + 1, Client.Bottom - FSpacing + 1));

    // Draw the picture
    if (FPicture.Graphic <> nil) then begin
        if (bsStretch in FStyle) then
             Picture := Rect(
            FBevelSize + FSpacing, FBevelSize + FSpacing, Width - (FBevelSize + FSpacing), Height - (FBevelSize + FSpacing))
         else if (bsCenter in FStyle) then
             Picture := Bounds(
               (Width - FPicture.Width) div 2, (Height - FPicture.Height) div 2,
             FPicture.Width, FPicture.Height
             )
        else
             case FAlignment of
               alTopLeft, alTopCenter, alTopRight:
                 Picture := Bounds(
                   (Width - FPicture.Width) div 2,
                 ((Height - (FBevelSize + FSpacing)) - FPicture.Height),
                   FPicture.Width, FPicture.Height
                 );
             alMiddleLeft:
                 Picture := Bounds(
                   ((Width - (FBevelSize + FSpacing)) - FPicture.Width),
                (Height - FPicture.Height) div 2,
                   FPicture.Width, FPicture.Height
                 );
             alMiddleCenter:
                 Picture := Bounds(
                   (Width - FPicture.Width) div 2,
                     (Height - FPicture.Height) div 2,
                     FPicture.Width, FPicture.Height
                     );
             alMiddleRight:
                 Picture := Bounds(
                   (FBevelSize + FSpacing),
                 (Height - FPicture.Height) div 2,
                   FPicture.Width, FPicture.Height
                       );
          alBottomLeft, alBottomCenter, alBottomRight:
                 Picture := Bounds(
                   (Width - FPicture.Width) div 2,
                (FBevelSize + FSpacing),
                   FPicture.Width, FPicture.Height
                );
          end;

        StretchDraw(Picture, FPicture.Graphic);
    end
    else begin
         Brush.Color := FColor;
         FillRect(Rect(FBevelSize, FBevelSize, Width - FBevelSize, Height - FBevelSize));
    end;

    // Draw the caption
    if (Caption <> '') then begin
      Brush.Style := bsClear;
      if ((not Enabled) and (not (csDesigning in ComponentState))) then begin
        Font.Color := FHighlightColor; DrawCaption(1, 1);
        Font.Color := FShadowColor; DrawCaption(0, 0);
      end
      else begin
        case FFontStyle of
        fnRaised: begin
          FontBase := Font.Color;
          Font.Color := FHighlightColor; DrawCaption(-1, -1);
          Font.Color := FShadowColor; DrawCaption(1, 1);
          Font.Color := FontBase; DrawCaption(0, 0);
        end;
        fnLowered: begin
          FontBase := Font.Color;
          Font.Color := FHighlightColor; DrawCaption(1, 1);
          Font.Color := FShadowColor; DrawCaption(-1, -1);
          Font.Color := FontBase; DrawCaption(0, 0);
        end;
        else
          DrawCaption(0, 0);
        end;
      end;
    end;
  end;
end;

procedure TColorButton.DoEnter;
begin
  FFocused := True;
  Repaint;

  inherited DoEnter;
end;

procedure TColorButton.DoExit;
begin
  FFocused := False;
  Repaint;

  inherited DoExit;
end;

procedure TColorButton.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);

  if (Key = VK_SPACE) and Enabled then begin
    if (bsMultiState in FStyle) then begin
      if FState = bsDown then FState := bsUp
      else FState := bsDown;
    end else FState := bsDown;
    Repaint;
  end;
end;

procedure TColorButton.KeyUp(var Key: Word; Shift: TShiftState);
begin
  inherited KeyUp(Key, Shift);

  if (Key = VK_SPACE) and Enabled then begin
    if not (bsMultiState in FStyle) then begin
      FState := bsUp;
      Repaint;
    end;
    Click;
  end;

  if (Key = VK_RETURN) and Enabled then begin
    if (bsMultiState in FStyle) then begin
      FState := bsDown;
      Repaint;
    end;
    Click;
  end;
end;

procedure TColorButton.KeyAccel(var Message: TCMDialogChar);
begin
  with Message do begin
    if IsAccel(CharCode, Caption) and Enabled then begin
      Click;
      Result := 1;
    end else inherited;
  end;
end;

procedure TColorButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);

  if Enabled then begin
    if (bsMultiState in FStyle) then begin
      if FState = bsDown then FState := bsUp
      else FState := bsDown;
    end else FState := bsDown;

    Repaint;
  end;
end;

procedure TColorButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);

  if Enabled then begin
    if not (bsMultiState in FStyle) then begin
      FState := bsUp;
      Repaint;
    end;
  end;
end;

procedure TColorButton.SetAlignment(Value: TAlignment);
begin
  if (FAlignment <> Value) then begin
    FAlignment := Value;
    Repaint;
  end;
end;

procedure TColorButton.SetBevelStyle(Value: TButtonBevel);
begin
  if (FBevelStyle <> Value) then begin
    FBevelStyle := Value;
    Repaint;
  end;
end;

procedure TColorButton.SetBevelSize(Value: Integer);
begin
  if (Value < 1) then Value := 1;

  if (FBevelSize <> Value) then begin
    FBevelSize := Value;
    Repaint;
  end;
end;

procedure TColorButton.SetCaption(var Message: TMessage);
begin
  Repaint;
end;

procedure TColorButton.SetColor(Value: TColor);
begin
  FShadowColor    := GetShadowColor(Value);
  FHighLightColor := GetHighlightColor(Value);

  FColor := Value;

  Repaint;
end;

procedure TColorButton.SetEnabled(var Message: TMessage);
begin
  inherited;

  if Enabled then FState := bsUp else FState := bsDisabled;
  Repaint;
end;

procedure TColorButton.SetFocusOff(var Message: TMessage);
begin
  inherited;

  FFocused := False;
  Repaint;
end;

procedure TColorButton.SetFocusOn(var Message: TMessage);
begin
  inherited;

  FFocused := True;
  Repaint;
end;

procedure TColorButton.SetFont(var Message: TMessage);
begin
  inherited;

  Repaint;
end;

procedure TColorButton.SetFontStyle(Value: TFontStyle);
begin
  if (FFontStyle <> Value) then begin
    FFontStyle := Value;
    Repaint;
  end;
end;

procedure TColorButton.SetPicture(Value: TPicture);
begin
  if (FPicture <> Value) then begin
    FPicture.Assign(Value);
    Repaint;
  end;
end;

procedure TColorButton.SetSize(var Message: TMessage);
begin
  Repaint;
end;

procedure TColorButton.SetSpacing(Value: Integer);
begin
  if (Value < 0) then Value := 0;

  if (FSpacing <> Value) then begin
    FSpacing := Value;
    Repaint;
  end;
end;

procedure TColorButton.SetStyle(Value: TButtonStyle);
begin
  if (FStyle <> Value) then begin
    FStyle := Value;

    Repaint;
  end;
end;

function TColorButton.GetValue: Boolean;
begin
  Result := (FState = bsDown);
end;

procedure TColorButton.SetValue(Value: Boolean);
begin
  if (bsMultiState in FStyle) then begin
    if Value then FState := bsDown
    else FState := bsUp;
    Repaint;
  end;
end;

end.