rxspin.pas

rx library V2.7.7a component use in delphi7 to delphi 2006

    if ADownState = sbBottomDown then begin
      Pen.Color := clBtnShadow;
      MoveTo(3, Height - 2);
      LineTo(Width - 1, 2);
    end;
  end;
end;
*)
type
  TColorArray = array[0..2] of TColor;

procedure TRxSpinButton.DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState);
const
  CColors: TColorArray = ( clBtnShadow, clBtnHighlight, clWindowFrame{clBtnFace});

var
  R, RSrc: TRect;
  dRect: Integer;
  Flags: array[0..1] of DWord;
  LColors: TColorArray;
  LGlyph: array[0..1] of Boolean;
  {Temp: TBitmap;}

  procedure RxDraw;
  begin
    { buttons }
    with ABitmap.Canvas do begin
      LColors := CColors;
      if ADownState = sbTopDown then begin
        LColors[0] := clBtnFace;
        LColors[2] := clBtnHighlight;
        Flags[0] := EDGE_SUNKEN;
      end;
      if ADownState = sbBottomDown then begin
        LColors[1] := clWindowFrame;
        LColors[2] := clBtnShadow;
        Flags[1] := EDGE_SUNKEN;
      end;
      DrawEdge(Handle, R, Flags[0], BF_TOPLEFT or BF_SOFT);
      DrawEdge(Handle, R, Flags[1], BF_BOTTOMRIGHT or BF_SOFT);
      InflateRect(R,-1,-1);

      Pen.Color := LColors[0];
      MoveTo(R.Left,R.Bottom-2);
      LineTo(R.Right-1,R.Top-1);

      Pen.Color := LColors[2];
      MoveTo(R.Right-1, R.Top);
      LineTo(R.Right-1, R.Top);
      LineTo(R.Left, R.Bottom-1);

      Pen.Color := LColors[1];
      MoveTo(R.Left+1,R.Bottom-1);
      LineTo(R.Right,R.Top);

      { top glyph }
      dRect := 1;
      if ADownState = sbTopDown then Inc(dRect);

      if LGlyph[0] then FUpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);
      if LGlyph[1] then FDownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);

      R := Bounds(Round((Width / 4) - (FUpBitmap.Width / 2)) + dRect,
        Round((Height / 4) - (FUpBitmap.Height / 2)) + dRect, FUpBitmap.Width,
        FUpBitmap.Height);
      RSrc := Bounds(0, 0, FUpBitmap.Width, FUpBitmap.Height);
      BrushCopy(R, FUpBitmap, RSrc, FUpBitmap.TransparentColor);
      { bottom glyph }
      R := Bounds(Round((3 * Width / 4) - (FDownBitmap.Width / 2)) - 1,
        Round((3 * Height / 4) - (FDownBitmap.Height / 2)) - 1,
        FDownBitmap.Width, FDownBitmap.Height);
      RSrc := Bounds(0, 0, FDownBitmap.Width, FDownBitmap.Height);
      BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor);
      FUpBitmap.Handle := 0;
      FDownBitmap.Handle := 0;
    end;
  end;

{$IFDEF POLESPIN}
  procedure PoleDraw;
  var
    X, Y, I, J, H: Integer;
    R1: TRect;
  begin
    with ABitmap.Canvas do begin
      { top glyph }
      H := Height div 2;
      R := Bounds(0, 0, Width, H);
      if ADownState = sbTopDown then Flags[0] := EDGE_SUNKEN
      else R.Bottom := R.Bottom+1;
      if ADownState = sbBottomDown then Flags[1] := EDGE_SUNKEN;
      if LGlyph[0] then FUpBitmap.Handle := LoadBitmap(HInstance, 'RSPINUP');
      RSrc := R;
      DrawEdge(Handle, R, Flags[0], BF_RECT or BF_SOFT or BF_ADJUST);
      R1 := Bounds(0, H, Width, Height);
      R1.Bottom := Height;
      DrawEdge(Handle, R1, Flags[1], BF_RECT or BF_SOFT or BF_ADJUST);
      I := R.Bottom - R.Top - 1;
      J := R1.Bottom - R1.Top - 1;
      Y := RSrc.Top+(H - FUpBitmap.Height) div 2;
//      if I >= (J+1) then
      if (ADownState = sbTopDown) then OffsetRect(R1, 0, 1);

      R1.Bottom := R1.Top+I;
      if  J-FUpBitmap.Height < 0 then Y := R.Top;
      {Glyph}
      FUpBitmap.Transparent := True;
      X := (Width - FUpBitmap.Width) div 2;
      IntersectClipRect(Handle, R.Left, R.Top, R.Right, R.Bottom);
      Draw(X, Y, FUpBitmap);
      SelectClipRgn(Handle,0);
      RSrc := Bounds(0, H, Width, Height);
      RSrc.Bottom := Height;
      if LGlyph[1] then FDownBitmap.Handle := LoadBitmap(HInstance, 'RSPINDOWN');
      FDownBitmap.Transparent := True;
      X := (Width - FDownBitmap.Width) div 2;
      Y := R1.Top + (I - FDownBitmap.Height) div 2;
      if I - FDownBitmap.Height < 0
      then begin
        Dec(R1.Top);
        Y := R1.Bottom - FDownBitmap.Height
      end;
      IntersectClipRect(Handle, R1.Left, R1.Top, R1.Right, R1.Bottom);
      Draw( X,
            Y,
            FDownBitmap);
      SelectClipRgn(Handle,0);
    end;
  end;
{$ENDIF}
begin
  LGlyph[0] := FUpBitmap.Handle = 0;
  LGlyph[1] := FDownBitmap.Handle = 0;
  try
    ABitmap.Height := Height;
    ABitmap.Width := Width;
    FillChar(Flags, SizeOf(Flags), EDGE_RAISED);
    with ABitmap.Canvas do begin
      R := Bounds(0, 0, Width, Height);
      Pen.Width := 1;
      Brush.Color := clBtnFace;
      Brush.Style := bsSolid;
      FillRect(R);
    end;
{$IFDEF POLESPIN}
    if FButtonStyle = sbsClassic
    then PoleDraw
    else
{$ENDIF}
    RxDraw;
  finally
    if LGlyph[0] then FUpBitmap.Handle := 0;
    if LGlyph[1] then FDownBitmap.Handle := 0;
  end;
end;

procedure TRxSpinButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
//>Polaris
//  FInvalidate := True;
//  Invalidate;
  GlyphChanged(Self);
//<Polaris
end;

//>Polaris
procedure TRxSpinButton.SetButtonStyle(Value: TrSpinButtonStyle);
begin
  if Value <> FButtonStyle then begin
    FButtonStyle := Value;
    GlyphChanged(Self);
  end;
end;
//<Polaris

procedure TRxSpinButton.TopClick;
begin
  if Assigned(FOnTopClick) then begin
    FOnTopClick(Self);
    if not (csLButtonDown in ControlState) then FDown := sbNotDown;
  end;
end;

procedure TRxSpinButton.BottomClick;
begin
  if Assigned(FOnBottomClick) then begin
    FOnBottomClick(Self);
    if not (csLButtonDown in ControlState) then FDown := sbNotDown;
  end;
end;

procedure TRxSpinButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then begin
    if (FFocusControl <> nil) and FFocusControl.TabStop and
      FFocusControl.CanFocus and (GetFocus <> FFocusControl.Handle) then
        FFocusControl.SetFocus;
    if FDown = sbNotDown then begin
      FLastDown := FDown;
//>Polaris
{$IFNDEF POLESPIN}
      if Y > (-(Height/Width) * X + Height) then begin
{$ELSE}
      if ((FButtonStyle=sbsDefault) and (Y > (-(Height/Width) * X + Height))) or
         ((FButtonStyle=sbsClassic) and (Y > (Height div 2))) then begin
{$ENDIF}
        FDown := sbBottomDown;
        BottomClick;
      end
      else begin
        FDown := sbTopDown;
        TopClick;
      end;
      if FLastDown <> FDown then begin
        FLastDown := FDown;
        Repaint;
      end;
      if FRepeatTimer = nil then FRepeatTimer := TTimer.Create(Self);
      FRepeatTimer.OnTimer := TimerExpired;
      FRepeatTimer.Interval := InitRepeatPause;
      FRepeatTimer.Enabled := True;
    end;
    FDragging := True;
  end;
end;

procedure TRxSpinButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TSpinButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then begin
    if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then begin
      NewState := FDown;
//>Polaris
{$IFNDEF POLESPIN}
      if Y > (-(Width / Height) * X + Height) then begin
{$ELSE}
      if ((FButtonStyle=sbsDefault)) and (Y > (-(Width / Height) * X + Height)) or
         ((FButtonStyle=sbsClassic) and (Y > (Height div 2))) then begin
{$ENDIF}
        if (FDown <> sbBottomDown) then begin
          if FLastDown = sbBottomDown then FDown := sbBottomDown
          else FDown := sbNotDown;
          if NewState <> FDown then Repaint;
        end;
      end
      else begin
        if (FDown <> sbTopDown) then begin
          if (FLastDown = sbTopDown) then FDown := sbTopDown
          else FDown := sbNotDown;
          if NewState <> FDown then Repaint;
        end;
      end;
    end else
      if FDown <> sbNotDown then begin
        FDown := sbNotDown;
        Repaint;
      end;
  end;
end;

procedure TRxSpinButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then begin
    FDragging := False;
    if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then begin
      FDown := sbNotDown;
      FLastDown := sbNotDown;
      Repaint;
    end;
  end;
end;

procedure TRxSpinButton.TimerExpired(Sender: TObject);
begin
  FRepeatTimer.Interval := RepeatPause;
  if (FDown <> sbNotDown) and MouseCapture then begin
    try
      if FDown = sbBottomDown then BottomClick else TopClick;
    except
      FRepeatTimer.Enabled := False;
      raise;
    end;
  end;
end;

function DefBtnWidth: Integer;
begin
  Result := GetSystemMetrics(SM_CXVSCROLL);
  if Result > 15 then Result := 15;
end;

type
  TRxUpDown = class(TCustomUpDown)
  private
    FChanging: Boolean;
    procedure ScrollMessage(var Message: TWMVScroll);
    procedure WMHScroll(var Message: TWMHScroll); message CN_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message CN_VSCROLL;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnClick;
  end;

constructor TRxUpDown.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Orientation := udVertical;
  Min := -1;
  Max := 1;
  Position := 0;
end;

destructor TRxUpDown.Destroy;
begin
  OnClick := nil;
  inherited Destroy;
end;

procedure TRxUpDown.ScrollMessage(var Message: TWMVScroll);
begin
  if Message.ScrollCode = SB_THUMBPOSITION then begin
    if not FChanging then begin
      FChanging := True;
      try
        if Message.Pos > 0 then Click(btNext)
        else if Message.Pos < 0 then Click(btPrev);
        if HandleAllocated then
          SendMessage(Handle, UDM_SETPOS, 0, 0);
      finally
        FChanging := False;
      end;
    end;
  end;
end;

procedure TRxUpDown.WMHScroll(var Message: TWMHScroll);
begin
  ScrollMessage(TWMVScroll(Message));
end;

procedure TRxUpDown.WMVScroll(var Message: TWMVScroll);
begin
  ScrollMessage(Message);
end;

procedure TRxUpDown.WMSize(var Message: TWMSize);
begin
  inherited;
  if Width <> DefBtnWidth then Width := DefBtnWidth;
end;

{ TRxCustomSpinEdit }

constructor TRxCustomSpinEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
//Polaris
  FFocused := False;

  FCheckOnExit := False;
  FLCheckMinValue:= True;
  FLCheckMaxValue:= True;
  FCheckMinValue := False;
  FCheckMaxValue := False;
//Polaris
  ControlStyle := ControlStyle - [csSetCaption];
  FIncrement := 1.0;
  FDecimal := 2;
  FEditorEnabled := True;
  FButtonKind := bkDiagonal;
(*
  {$IFDEF POLESPIN}
  FButtonKind := bkClassic;
  {$ELSE}
  FButtonKind := bkDiagonal;
  {$ENDIF}
*)
  FArrowKeys := True;
  RecreateButton;
end;

destructor TRxCustomSpinEdit.Destroy;
begin
  Destroying;
  FChanging := True;
  if FButton <> nil then begin
    FButton.Free;
    FButton := nil;
    FBtnWindow.Free;
    FBtnWindow := nil;
  end;
  if FUpDown <> nil then begin
    FUpDown.Free;
    FUpDown := nil;
  end;
  inherited Destroy;
end;

procedure TRxCustomSpinEdit.RecreateButton;
begin
  if (csDestroying in ComponentState) then Exit;
  FButton.Free;
  FButton := nil;
  FBtnWindow.Free;
  FBtnWindow := nil;
  FUpDown.Free;
  FUpDown := nil;
  if GetButtonKind = bkStandard then begin
    FUpDown := TRxUpDown.Create(Self);
    with TRxUpDown(FUpDown) do begin
      Visible := True;
//Polaris
      SetBounds(0, 1, DefBtnWidth, Self.Height);
{$IFDEF RX_D4}
      if (BiDiMode = bdRightToLeft) then Align := alLeft else
{$ENDIF}
      Align := alRight;
      Parent := Self;
      OnClick := UpDownClick;
    end;
  end
  else begin
    FBtnWindow := TWinControl.Create(Self);
    FBtnWindow.Visible := True;
    FBtnWindow.Parent := Self;
{$IFDEF POLESPIN}
    if FButtonKind <> bkClassic
    then FBtnWindow.SetBounds(0, 0, DefBtnWidth, Height)
    else
{$ENDIF}
    FBtnWindow.SetBounds(0, 0, Height, Height);

    FButton := TRxSpinButton.Create(Self);
    FButton.Visible := True;
{$IFDEF POLESPIN}
    if FButtonKind = bkClassic
    then FButton.FButtonStyle := sbsClassic;
{$ENDIF}
    FButton.Parent := FBtnWindow;
    FButton.FocusControl := Self;
    FButton.OnTopClick := UpClick;
    FButton.OnBottomClick := DownClick;
//Polaris
    FButton.SetBounds(1, 1, FBtnWindow.Width-1, FBtnWindow.Height-1);
  end;
end;

procedure TRxCustomSpinEdit.SetArrowKeys(Value: Boolean);
begin
  FArrowKeys := Value;
  ResizeButton;
end;

function TRxCustomSpinEdit.GetButtonKind: TSpinButtonKind;
begin
  if NewStyleControls then Result := FButtonKind
{$IFNDEF POLESPIN}
  else Result := bkDiagonal;
{$ELSE}
//>Polaris
  else begin
      Result := bkDiagonal;
      if Assigned(FButton) and (FButton.ButtonStyle = sbsClassic)
      then Result := bkClassic;
  end;
//<Polaris
{$ENDIF}
end;

procedure TRxCustomSpinEdit.SetButtonKind(Value: TSpinButtonKind);
var
  OldKind: TSpinButtonKind;
begin
  OldKind := FButtonKind;
  FButtonKind := Value;
  if OldKind <> GetButtonKind then begin
    RecreateButton;
    ResizeButton;
    SetEditRect;
  end;
end;

procedure TRxCustomSpinEdit.UpDownClick(Sender: TObject; Button: TUDBtnType);
begin
  if TabStop and CanFocus then SetFocus;
  case Button of
    btNext: UpClick(Sender);
    btPrev: DownClick(Sender);
  end;
end;

function TRxCustomSpinEdit.GetButtonWidth: Integer;
begin
  if FUpDown <> nil then Result := FUpDown.Width else
  if FButton <> nil then Result := FButton.Width
  else Result := DefBtnWidth;
end;

procedure TRxCustomSpinEdit.ResizeButton;
var
  R: TRect;
begin
  if FUpDown <> nil then begin
    FUpDown.Width := DefBtnWidth;
 {$IFDEF RX_D4}
    if (BiDiMode = bdRightToLeft) then FUpDown.Align := alLeft else
 {$ENDIF}
    FUpDown.Align := alRight;
  end
  else if FButton <> nil then begin { bkDiagonal }
    if NewStyleControls and Ctl3D and (BorderStyle = bsSingle) then
{$IFDEF POLESPIN}
      if FButtonKind = bkClassic
      then R := Bounds(Width - DefBtnWidth - 4, -1, DefBtnWidth, Height - 3)
      else
{$ENDIF}
      R := Bounds(Width - Height - 1, -1, Height - 3, Height - 3)
    else
{$IFDEF POLESPIN}
      if FButtonKind = bkClassic
      then R := Bounds(Width - DefBtnWidth, 0, DefBtnWidth, Height)
      else
{$ENDIF}
      R := Bounds(Width - Height, 0, Height, Height);
 {$IFDEF RX_D4}
    if (BiDiMode = bdRightToLeft) then begin
      if NewStyleControls and Ctl3D and (BorderStyle = bsSingle) then begin
        R.Left := -1;
        R.Right := Height - 4;
      end
      else begin
        R.Left := 0;
        R.Right := Height;
      end;
    end;
 {$ENDIF}
    with R do