unit arrowbtn;


{********************************************************************
  TArrowButton component for Delphi
  
  Author: Kent Miller  Frederick, MD
  Compuserve: 74113,200
  
  Freeware: Feel free to use and improve
    
    I welcome any comments or suggestions that you may have, however
  I am new to creating components so please be gentle.
*********************************************************************}


interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs;

type
  TButtonDirection = (arwUP, arwRIGHT, arwLEFT, arwDOWN);

  TArrowButton = class(TGraphicControl)
  private
    kDirection: TButtonDirection;
    kButtonColor: TColor;
    kButtonDown: boolean;
    kpnts: array[1..3] of TPoint;
    kRgn: HRgn;

    procedure SetDirection(value: TButtonDirection);
    procedure SetButtonColor(value: TColor);
    procedure FreeRegion;
  protected
    procedure Paint; override;
    procedure DrawUpArrow;
    procedure DrawRightArrow;
    procedure DrawDownArrow;
    procedure DrawLeftArrow;
    procedure MoveButton; virtual;
    procedure WMLButtonDown(var Message: TWMLButtonDown);
                      message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TWMLButtonUp);
                      message WM_LBUTTONUP;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ButtonColor: TColor read kButtonColor write SetButtonColor;
    property Direction: TButtonDirection read kDirection write SetDirection;
    property Enabled;
    property ParentShowHint;
    property ShowHint;
    property Visible;

    property OnClick;
  end;

procedure Register;

implementation

const
  { offset from border of control to corner of button }
  S_OFFSET = 3;

constructor TArrowButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csClickEvents, csCaptureMouse];
  Width := 33;
  Height := 33;
  kDirection := arwUP;
  kButtonColor := clTeal;
  kRgn := 0;
  kButtonDown := False;
end;

destructor TArrowButton.Destroy;
begin
  if kRgn <> 0 then
    FreeRegion;
  inherited Destroy;
end;

procedure TArrowButton.Paint;
begin
  inherited Paint;
  FreeRegion;
  case kDirection of
    arwUP: DrawUpArrow;
    arwRIGHT: DrawRightArrow;
    arwDOWN: DrawDownArrow;
    arwLEFT: DrawLeftArrow;
  end;
end;

procedure TArrowButton.DrawUpArrow;
begin
  Canvas.Brush.Color := clBlack;
  Canvas.Pen.Color := clBlack;
  { create border region for button }
  kpnts[1] := Point(Width div 2, S_OFFSET);
  kpnts[2] := Point(Width - S_OFFSET, Height - S_OFFSET);
  kpnts[3] := Point(S_OFFSET, Height - S_OFFSET);
  { save region to capture mouse clicks }
  kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  { draw black border around button }
  FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  { create region within black border for button }
  Inc(kpnts[1].Y, 3);
  Dec(kpnts[2].X, 4);
  Dec(kpnts[2].Y, 2);
  Inc(kpnts[3].X, 3);
  Dec(kpnts[3].Y, 2);
  Canvas.Brush.Color := kButtonColor;
  { draw button }
  Canvas.Polygon(kpnts);
  MoveButton;
end;

procedure TArrowButton.DrawRightArrow;
begin
  Canvas.Brush.Color := clBlack;
  Canvas.Pen.Color := clBlack;
  kpnts[1] := Point(S_OFFSET, S_OFFSET);
  kpnts[2] := Point(Width - S_OFFSET, Height div 2);
  kpnts[3] := Point(S_OFFSET, Height - S_OFFSET);
  kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  Inc(kpnts[1].X, 2);
  Inc(kpnts[1].Y, 3);
  Dec(kpnts[2].X, 3);
  Inc(kpnts[3].X, 2);
  Dec(kpnts[3].Y, 3);
  Canvas.Brush.Color := kButtonColor;
  Canvas.Polygon(kpnts);
  MoveButton;
end;

procedure TArrowButton.DrawDownArrow;
begin
  Canvas.Brush.Color := clBlack;
  Canvas.Pen.Color := clBlack;
  kpnts[1] := Point(Width - S_OFFSET, S_OFFSET);
  kpnts[2] := Point(Width div 2, Height - S_OFFSET);
  kpnts[3] := Point(S_OFFSET, S_OFFSET);
  kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  Dec(kpnts[1].X, 3);
  Inc(kpnts[1].Y, 2);
  Dec(kpnts[2].Y, 3);
  Inc(kpnts[3].X, 2);
  Inc(kpnts[3].Y, 2);
  Canvas.Brush.Color := kButtonColor;
  Canvas.Polygon(kpnts);
  MoveButton;
end;

procedure TArrowButton.DrawLeftArrow;
begin
  Canvas.Brush.Color := clBlack;
  Canvas.Pen.Color := clBlack;
  kpnts[1] := Point(Width - S_OFFSET, S_OFFSET);
  kpnts[2] := Point(Width - S_OFFSET, Height - S_OFFSET);
  kpnts[3] := Point(S_OFFSET, Height div 2);
  kRgn := CreatePolygonRgn(kpnts, 3, ALTERNATE);
  FrameRgn(Canvas.Handle, kRgn, Canvas.Brush.Handle, 2, 2);
  Dec(kpnts[1].X, 2);
  Inc(kpnts[1].Y, 3);
  Dec(kpnts[2].X, 2);
  Dec(kpnts[2].Y, 2);
  Inc(kpnts[3].X, 3);
  Canvas.Brush.Color := kButtonColor;
  Canvas.Polygon(kpnts);
  MoveButton;
end;

procedure TArrowButton.MoveButton;
begin
  if not kButtonDown then  { button is in up position }
    with Canvas do
      begin
        { draw lines around button for raised look }
        Pen.Color := clBlack;
        MoveTo(kpnts[1].X, kpnts[1].Y);
        LineTo(kpnts[2].X, kpnts[2].Y);
        MoveTo(kpnts[2].X, kpnts[2].Y);
        LineTo(kpnts[3].X, kpnts[3].Y);
        Pen.Color := clWhite;
        MoveTo(kpnts[1].X, kpnts[1].Y);
        LineTo(kpnts[3].X, kpnts[3].Y);
      end
  else  { button is in down position }
    with Canvas do
      begin
        { draw lines around button for sunken look }
        Pen.Color := clBlack;
        MoveTo(kpnts[1].X, kpnts[1].Y);
        LineTo(kpnts[3].X, kpnts[3].Y);
        Pen.Color := kButtonColor;
        MoveTo(kpnts[1].X, kpnts[1].Y);
        LineTo(kpnts[2].X, kpnts[2].Y);
        MoveTo(kpnts[2].X, kpnts[2].Y);
        LineTo(kpnts[3].X, kpnts[3].Y);
      end;
end;

procedure TArrowButton.SetDirection(value: TButtonDirection);
begin
  if value <> kDirection then
    begin
      kDirection := value;
      Invalidate;
    end;
end;

procedure TArrowButton.SetButtonColor(value: TColor);
begin
  if value <> kButtonColor then
    begin
      kButtonColor := value;
      Invalidate;
    end;
end;

procedure TArrowButton.FreeRegion;
begin
  if kRgn <> 0 then
    DeleteObject(kRgn);
  kRgn := 0;
end;

procedure TArrowButton.WMLButtonDown(var Message: TWMLButtonDown);
begin
  { if mouse is clicked on the arrowbutton make it appear sunken }
  if not PtInRegion(kRgn, Message.xPos, Message.yPos) then Exit;
  kButtonDown := True;
  MoveButton;
  inherited;
end;

procedure TArrowButton.WMLButtonUp(var Message: TWMLButtonUp);
begin
  { if arrowbutton is down and mouse is released then
    make arrowbutton appear raised }
  if not kButtonDown then Exit;
  kButtonDown := False;
  MoveButton;
  inherited;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TArrowButton]);
end;

end.