(************************************************************************
*    This File is Part of the AHM Triton Tools                          *
*    for Borland Delphi and C++ Builder.                                *
*************************************************************************
* Copyright © 1995-1999 Alexander H. Mehlhorn (AHM) and Tritontools.com *
* All Rights reserved.                                                  *
*                                                                       *
*    For more Information contact us at                                 *
*    E-Mail : support@tritontools.com                                   *
*    URL : http://www.tritontools.com                                   *
*                                                                       *
*    AHM is copyright by Alexander H. Mehlhorn                          *
*    All Parts of this Collection were developed,                       *
*    designed and implemented by AHM                                    *
*                                                                       *
*    Under no Circumstances may you distribute this file                *
*    in this or any other format. This File is supplied                 *
*    as Evaluation of Source only. No Delphi Components may be developed*
*    using extracts or subsets of this code without expressed permission*
*    by AHM.                                                            *
*                                                                       *
*************************************************************************)
unit AHMTSpinEdit;

interface
{$I AHM.INC}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  stdctrls,AHMStdClass;

type
  TAHMButtonState      = (bsUp, bsTopDown, bsBottomDown, bsDisabled);
  TAHMCustomSpinButton = class(TGraphicControl)
  private
    FCache:TBitmap;
    FDown,
    FLastDown: TAHMButtonState;
    FDragging: Boolean;
    FOnTopClick: TNotifyEvent;
    FaColor,FColor : TColor;
    FOnBottomClick: TNotifyEvent;
    procedure SetColor(value : TColor);
    procedure SetAColor(value : TColor);
    procedure SetDown(Value: TAHMButtonState);
    procedure CreateStates;
    procedure DrawState(State:TAHMButtonState);
    procedure CMEnabledChanged(var Msg:TMessage); message CM_EnabledChanged;
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(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;
    property Down: TAHMButtonState read FDown write SetDown default bsUp;
  published
    property Enabled;
    property ShowHint;
    property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;
    property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;
    property Color : TColor read fcolor write SetColor default clBtnFace;
    property ArrowColor : TColor read faColor write SetAColor default clBlack;
  end;
  TAHMCustomSpinEdit = class(TCustomEdit)
  private
    FMinValue,
    FMaxValue,
    FLineSize,
    FMultipleLineSize:LongInt;
    FCutandPaste:Boolean;
    FButton:Pointer;
    FButtonWin: TWinControl;
    procedure SetEditRect;
    procedure SetInteger(Index:Integer; aValue:LongInt);
    procedure SetValue(aValue:LongInt);
    function GetMinHeight: Integer;
    function GetValue: LongInt;
    function CheckValue(aValue:LongInt):LongInt;
    procedure SetBColor(value : TColor);
    Function GetBColor : TColor;
    procedure SetAColor(value : TColor);
    Function GetAColor : TColor;
    procedure CMEnabledChanged(var Msg:TMessage); message CM_EnabledChanged;
    procedure CMEnter(var Message: TCMGOTFOCUS);message CM_ENTER;
    procedure CMExit(var Message: TCMExit);message CM_EXIT;
    procedure WMCut(var Message: TWMCut);message WM_CUT;
    procedure WMPaste(var Message: TWMPaste);message WM_PASTE;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure DownClick (Sender: TObject); virtual;
    procedure AdjustSize;{$IFDEF AHMINPRISE4} override; {$ENDIF}
    function IsValidChar(Key: Char): Boolean; virtual;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure UpClick (Sender: TObject); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Button: Pointer read FButton;
  published
    property AutoSelect;
    property AutoSize;
    {$IFDEF AHMINPRISE4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property ParentBiDiMode;
    {$ENDIF}
    property Color;
    property Ctl3D;
    property ButtonColor : TColor read GetBColor write SetBColor default clBtnFace;
    property ArrowColor : TColor read GetAColor write SetAColor default clblack;
    property CutandPaste: Boolean read FCutandPaste write FCutandPaste default True;
    property Enabled;
    property Font;
    {$IFDEF AHMINPRISE3}
    property ImeMode;
    property ImeName;
    {$ENDIF}
    property LineSize:LongInt index 2 read FLineSize write SetInteger default 1;
    property MaxLength;
    property MaxValue:LongInt index 0 read FMaxValue write SetInteger default 100;
    property MinValue:LongInt index 1 read FMinValue write SetInteger default 0;
    property MultipleLineSize:LongInt index 3 read FMultipleLineSize write SetInteger default 10;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Value:LongInt read GetValue write SetValue default 0;
    property Visible;
    property OnChange;
    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;
  end;
  TAHMSpinButtonState = (sbUp, sbTopDown, sbBottomDown, sbDisabled);
  TAHMSpinButton = class(TAHMCustomSpinButton)
  private
    FAboutStr : TAHMAboutSControlStr;
  protected
  public
  published
    property About : TAHMAboutSControlStr read FAboutStr write FAboutStr;
  end;
  TAHMSpinEdit = class(TAHMCustomSpinEdit)
  private
    FAboutStr : TAHMAboutSControlStr;
  protected
  public
  published
    property About : TAHMAboutSControlStr read FAboutStr write FAboutStr;
  end;

implementation

procedure TAHMCustomSpinButton.SetDown(Value: TAHMButtonState);
var OldState: TAHMButtonState;
begin
  OldState := FDown;
  FDown := Value;
  if OldState<>FDown then Paint;
end;

procedure TAHMCustomSpinButton.CMEnabledChanged(var Msg:TMessage);
begin
  inherited;
  if Enabled then FDown:=bsUp else FDown:=bsDisabled;
  Paint;
end;

procedure TAHMCustomSpinButton.SetColor(value : TColor);
begin
  fcolor:=value;
  CreateStates;
  Paint;
end;

procedure TAHMCustomSpinButton.SetAColor(value : TColor);
begin
  facolor:=value;
  CreateStates;
  Paint;
end;

procedure TAHMCustomSpinButton.Paint;
begin
  if not Enabled and not (csDesigning in ComponentState) then
    FDragging := False;
  if (FCache.Height<>Height) or (FCache.Width div 4<>Width) then CreateStates;
  Canvas.Draw(0,0, FCache);
  Canvas.CopyRect(ClientRect, FCache.Canvas, Rect(Ord(FDown)*Width, 0,
                 (Ord(FDown)+1)*Width, FCache.Height));
end;

procedure TAHMCustomSpinButton.CreateStates;
begin
  FCache.Width:=4*Width;
  FCache.Height:=Height;
  DrawState(bsUp);
  DrawState(bsTopDown);
  DrawState(bsBottomDown);
  DrawState(bsDisabled);
end;

procedure TAHMCustomSpinButton.DrawState(State:TAHMButtonState);
var Re:TRect;
    dRect:Integer;
    FButtonBitmap:TBitmap;
Procedure AHMGetTriangle(fCanvas: TCanvas; x,y,size: integer; Col: TColor; Down,Enabled:Boolean);
var
  i: integer;
begin
  if (size<2) or (size>15) then exit;
  with fCanvas do
  begin
    if not Enabled then AHMGetTriangle(fCanvas,x+1,y+1,size,clHighlightText,Down,True);
    Pen.Width:=1;
    Pen.Style:=psSolid;
    if Enabled then Pen.Color:=Col else Pen.Color:=clGrayText;
    if Down then
    begin
      for i:=0 to size-2 do
      begin
        MoveTo(x+i,y+i);
        LineTo(x+i+((size-i)*2)-1,y+i);
      end;
      MoveTo(x+(size-1),y+size-1);
      LineTo(x+(size-1),y+size-2);
    end else
    begin
      x:=x+(size div 2);
      for i:=0 to Pred(size) do
      begin
        MoveTo(x-i,y+i);
        LineTo(x+i+1,y+i);
      end;
    end;
  end;
end;
begin
  FButtonBitmap:=TBitmap.Create;
  try
    FButtonBitmap.Height:=Height;
    FButtonBitmap.Width:=Width;
    with FButtonBitmap, FButtonBitmap.Canvas do
    begin
      Re:=Bounds(0, 0, Width, Height);
      Brush.Color:=fcolor;
      Brush.Style:=bsSolid;
      Pen.Color := clwhite;
      Pen.Style:=psSolid;
      Pen.Width:=1;
      Rectangle(0, 0, Width, Height);
      if State<>bsTopDown then
        DrawEdge(FButtonBitmap.canvas.handle,Re,EDGE_RAISED,BF_TOPLEFT or BF_SOFT)
      else
        DrawEdge(FButtonBitmap.canvas.handle,Re,EDGE_SUNKEN,BF_TOPLEFT or BF_SOFT);
      if State<>bsBottomDown  then
        DrawEdge(FButtonBitmap.canvas.handle,Re,EDGE_RAISED,BF_BOTTOMRIGHT)
      else
        DrawEdge(FButtonBitmap.canvas.handle,Re,EDGE_SUNKEN,BF_BOTTOMRIGHT);
      Pen.Color := clWindowFrame;
      if State<>bsTopDown then Pen.Color:=clbtnshadow else Pen.Color:=clBtnHighlight;
      MoveTo(0,Height-2);
      LineTo(Width-2,0);
      Pen.Color:=clwindowframe;
      MoveTo(0,Height-1);
      LineTo(Width-1,0);
      if State=bsBottomDown  then Pen.Color:=clBtnShadow else Pen.Color:=clBtnHighlight;
      MoveTo(0,Height);
      LineTo(Width,0);
      Canvas.Brush.Style:=bsClear;
      if State<>bsTopDown then dRect:=1 else dRect:=2;
      AHMGetTriangle(Canvas,Round((Width/4)-2)+dRect,Round((Height/4)-2)+dRect,3,faColor,false,State<>bsDisabled);
      if State=bsBottomDown then dRect:=0 else dRect:=1;
      AHMGetTriangle(Canvas,Round((3*Width/4)-2)-dRect,Round((3*Height/4)-2)-dRect,3,faColor,true,State<>bsDisabled);
    end;
    FCache.Canvas.CopyRect(Rect(Ord(State)*FButtonBitmap.Width,0, (Ord(State)+1)*FButtonBitmap.Width, FCache.Height),
                           FButtonBitmap.Canvas, Rect(0,0, FButtonBitmap.Width, FButtonBitmap.Height));
  finally
    FButtonBitmap.Free;
  end;
end;

procedure TAHMCustomSpinButton.MouseDown(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button=mbLeft) and Enabled then
  begin
    if FDown=bsUp then
    begin
      FLastDown := FDown;
      if Y>(-(Width/Height)*X + Height) then
      begin
        FDown:=bsBottomDown;
      end else
      begin
        FDown:=bsTopDown;
      end;
      if FLastDown <> FDown then
      begin
        FLastDown := FDown;
        Paint;
      end;
    end;
    FDragging := True;
  end;
end;

procedure TAHMCustomSpinButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TAHMButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  if PtInRect(ClientRect, Point(X,Y)) then
  begin
    NewState:=FDown;
    if Y>(-(Width/Height)*X + Height) then
    begin
      if (FDown<>bsBottomDown) then
      begin
        if FLastDown = bsBottomDown then FDown := bsBottomDown else FDown := bsUp;
        if NewState<>FDown then Paint;
      end;
    end else
    begin
      if (FDown<>bsTopDown) then
      begin
        if (FLastDown = bsTopDown) then FDown:=bsTopDown else FDown:=bsUp;
        if NewState<>FDown then Paint;
      end;
    end;
  end else if FDown<>bsUp then
  begin
    FDown:=bsUp;
    Paint;
  end;
end;

procedure TAHMCustomSpinButton.MouseUp(Button: TMouseButton; Shift: TShiftState;X, Y: Integer);
var
  NewState: TAHMButtonState;
begin
  Newstate:=FDown;
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then
  begin
    FDragging := False;
    if PtInRect(ClientRect,Point(X,Y)) then
    begin
      FDown:=bsUp;
      FLastDown:=bsUp;
      Paint;
    end;
  end;
  if Newstate=bsBottomDown then
  begin
    if Assigned(FOnBottomClick) then FOnBottomClick(Self);
  end else if Assigned(FOnTopClick) then FOnTopClick(Self);
end;

constructor TAHMCustomSpinButton.Create(AOwner: TComponent);
begin
  fcolor := clbtnface;
  facolor:= clBlack;
  inherited Create(AOwner);
  FCache:=TBitmap.Create;
  FDown:=bsup;
  FLastDown:=bsUp;
  Height:=20;
  Width:=20;
end;

destructor TAHMCustomSpinButton.Destroy;
begin
  FCache.Free;
  inherited Destroy;
end;

procedure TAHMCustomSpinEdit.SetEditRect;
var
  r: TRect;
begin
  r:=Rect(0,0, ClientWidth-TAHMCustomSpinButton(FButton).Width-2, ClientHeight+1);
  SendMessage(Handle, EM_SETRECTNP, 0, LongInt(@r));
  SendMessage(Handle, EM_GETRECT, 0, LongInt(@r));
end;

procedure TAHMCustomSpinEdit.SetInteger(Index:Integer; aValue:LongInt);
begin
  case Index of
    0: if (aValue<>FMaxValue) and (aValue>FMinValue) then
       begin
         FMaxValue:=aValue;
         if Value>FMaxValue then Value:=FMaxValue;
       end;
    1: if (aValue<>FMinValue) and (aValue<FMaxValue) then
       begin
          FMinValue:=aValue;
          if Value<FMinValue then Value:=FMinValue;
       end;
    2: FLineSize:=aValue;
    3: FMultipleLineSize:=aValue;
  end;
end;

procedure TAHMCustomSpinEdit.SetValue(aValue:LongInt);
begin
  Text:=IntToStr(CheckValue(aValue));
end;

function TAHMCustomSpinEdit.GetMinHeight: Integer;
var DC: HDC;
    SaveFont: HFont;
    h: Integer;
    SysMetrics, Metrics: TTextMetric;
begin
  DC:=GetDC(0);
  try
    GetTextMetrics(DC, SysMetrics);
    SaveFont := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, SaveFont);
  finally
    ReleaseDC(0, DC);
  end;
  h:=SysMetrics.tmHeight;
  if h>Metrics.tmHeight then h:=Metrics.tmHeight;
  Result:=Metrics.tmHeight+ h div 4 + GetSystemMetrics(SM_CYBORDER) * 4;
end;

function TAHMCustomSpinEdit.GetValue:LongInt;
begin
  if (Text='') then Text:=IntToStr(MinValue);
  try
    Result:=StrToInt(Text);
  except
    Result:=FMinValue;
  end;
end;

procedure TAHMCustomSpinEdit.AdjustSize;
var MinHeight: Integer;
begin
  MinHeight:=GetMinHeight;
  if Height<MinHeight then Height:=MinHeight else
  begin
    if NewStyleControls and CTL3D then FButtonWin.SetBounds(Width-Height,0,Height-4,Height-4)
                                  else FButtonWin.SetBounds(Width - Height, 0, Height, Height);
    TAHMCustomSpinButton(FButton).SetBounds(0, 0, FButtonWin.Height, FButtonWin.Height);
    SetEditRect;
  end;
end;

function TAHMCustomSpinEdit.CheckValue(aValue:LongInt): LongInt;
begin
  Result:=aValue;
  if (FMaxValue<>FMinValue) then
  begin
    if aValue<FMinValue then Result:=FMinValue;
    if aValue>FMaxValue then Result:=FMaxValue;
  end;
end;

procedure TAHMCustomSpinEdit.CMEnabledChanged(var Msg:TMessage);
begin
  inherited;
  TAHMCustomSpinButton(FButton).Enabled:=Enabled;
end;

procedure TAHMCustomSpinEdit.CMEnter(var Message: TCMGotFocus);
begin
  if AutoSelect and not (csLButtonDown in ControlState) then SelectAll;
  inherited;
end;

procedure TAHMCustomSpinEdit.CMExit(var Message: TCMExit);
begin
  inherited;
  if CheckValue(Value)<>Value then SetValue(Value);
end;

procedure TAHMCustomSpinEdit.WMCut(var Message: TWMPaste);
begin
  if not FCutandPaste or Readonly then Exit;
  inherited;
end;

procedure TAHMCustomSpinEdit.WMPaste(var Message: TWMPaste);
begin
  if not FCutandPaste or Readonly then Exit;
  inherited;
end;

procedure TAHMCustomSpinEdit.WMSize(var Message: TWMSize);
begin
  inherited;
  AdjustSize;
end;


procedure TAHMCustomSpinEdit.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or ES_MULTILINE or WS_CLIPCHILDREN;
end;

procedure TAHMCustomSpinEdit.CreateWnd;
begin
  inherited CreateWnd;
  AdjustSize;
  SetEditRect;
end;

procedure TAHMCustomSpinEdit.DownClick (Sender: TObject);
begin
  if Readonly then MessageBeep(0) else Value:=Value-FLineSize;
end;

function TAHMCustomSpinEdit.IsValidChar(Key: Char): Boolean;
var
  ValidChar: set of Char;
begin
  ValidChar:=['+','-','0'..'9'];
  result:=(Key in ValidChar) or (Key < #32);
  if not FCutandPaste and Result and ((Key>=#32) or (Key=Char(VK_BACK)) or (Key=Char(VK_DELETE))) then
    result:=false;
end;

procedure TAHMCustomSpinEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  case key of
    VK_UP:UpClick (Self);
    VK_DOWN: DownClick (Self);
    VK_PRIOR: if not Readonly then value:=Value+FMultipleLineSize;
    VK_NEXT: if not Readonly then Value:=Value-FMultipleLineSize;
  end;
  inherited KeyDown(Key, Shift);
end;

procedure TAHMCustomSpinEdit.KeyPress(var Key: Char);
begin
  if not IsValidChar(Key) then
  begin
    Key:=#0;
    MessageBeep(0)
  end;
  if Key<>#0 then
  begin
    inherited KeyPress(Key);
    if (Key=Char(VK_RETURN)) or (Key=Char(VK_ESCAPE)) then
    begin
      GetParentForm(Self).Perform(CM_DIALOGKEY, Byte(Key), 0);
      if Key=Char(VK_RETURN) then Key := #0;
    end;
  end;
end;

Function TAHMCustomSpinEdit.GetBColor : TColor;
begin
  result:=TAHMCustomSpinButton(FButton).Color;
end;

procedure TAHMCustomSpinEdit.SetBColor(value : TColor);
begin
  TAHMCustomSpinButton(FButton).Color:=value;
end;

Function TAHMCustomSpinEdit.GetAColor : TColor;
begin
  result:=TAHMCustomSpinButton(FButton).ArrowColor;
end;

procedure TAHMCustomSpinEdit.SetAColor(value : TColor);
begin
  TAHMCustomSpinButton(FButton).ArrowColor:=value;
end;


procedure TAHMCustomSpinEdit.UpClick(Sender: TObject);
begin
  if Readonly then MessageBeep(0) else Value:=Value+FLineSize;
end;

constructor TAHMCustomSpinEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle - [csSetCaption];
  FButtonWin:=TWinControl.Create(Self);
  FButtonWin.Visible := True;
  FButtonWin.Parent := Self;
  FButtonWin.SetBounds(0, 0, Height, Height);
  FButton:=TAHMCustomSpinButton.Create(FButtonWin);
  with TAHMCustomSpinButton(FButton) do
  begin
    Parent:=FButtonWin;
    OnTopClick:=UpClick;
    OnBottomClick:=DownClick;
    SetBounds(0, 0, FButtonWin.Width, FButtonWin.Height);
  end;
  Text := '0';
  FLineSize := 1;
  FMultipleLineSize:=10;
  FMinValue:=0;
  FMaxValue:=100;
  FCutandPaste := True;
end;

destructor TAHMCustomSpinEdit.Destroy;
begin
  TAHMCustomSpinButton(FButton).Parent:=nil;
  TAHMCustomSpinButton(FButton).Free;
  inherited Destroy;
end;

end.
