tntjvspin.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

    end;
    }
    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);
    {
    if Self.Enabled or (csDesigning in ComponentState) then
      BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor)
    else
    begin
      Temp := CreateDisabledBitmap(FDownBitmap, clBlack);
      try
        BrushCopy(R, Temp, RSrc, Temp.TransparentColor);
      finally
        Temp.Free;
      end;
    end;
    }
    BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor);
    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;
  {$IFDEF VisualCLX}
  THackedCustomForm = class(TCustomForm);
  {$ENDIF VisualCLX}

  TJvUpDown = class(TCustomUpDown)
  private
    FChanging: Boolean;
  {$IFDEF VCL}
    procedure ScrollMessage(var Msg: TWMVScroll);
    procedure WMHScroll(var Msg: TWMHScroll); message CN_HSCROLL;
    procedure WMVScroll(var Msg: TWMVScroll); message CN_VSCROLL;
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  protected
    procedure Click(Button: TUDBtnType); override;
  {$ENDIF VisualCLX}
  public
    procedure Resize; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnClick;
  end;

  { The face of a spin button is stored because they are a bit to complex to
    calculate everytime in a Paint method. There are multiple bitmaps stored
    for a single spin button, eg disable/top-down/bottom down etc.

    The face bitmaps of a spin button are stored in a TSpinButtonBitmaps
    object. Multiple spin buttons can use the same TSpinButtonBitmaps object.
    (That is, identical spin buttons (same height, width, button kind etc.) use the
    same TSpinButtonbitmaps objects) The TSpinButtonBitmaps objects are managed
    by a single TSpinButtonBitmapsManager object.
  }

  TSpinButtonBitmapsManager = class;

  TSpinButtonBitmaps = class
  private
    FManager: TSpinButtonBitmapsManager;
    FHeight: Integer;
    FWidth: Integer;
    FStyle: TJvSpinButtonStyle;
    FClientCount: Integer;

    FTopDownBtn: TBitmap;
    FBottomDownBtn: TBitmap;
    FNotDownBtn: TBitmap;
    FDisabledBtn: TBitmap;
    FCustomGlyphs: Boolean;
    FResetOnDraw: Boolean;
    {$IFDEF JVCLThemesEnabled}
    FTopHotBtn: TBitmap;
    FBottomHotBtn: TBitmap;
    FIsThemed: Boolean;
    {$ENDIF JVCLThemesEnabled}
  protected
    procedure DrawAllBitmap;
    procedure DrawBitmap(ABitmap: TBitmap; ADownState: TSpinButtonState; const Enabled: Boolean);
    procedure PoleDrawArrows(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;
      AUpArrow, ADownArrow: TBitmap);
    procedure JvDrawArrows(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;
      AUpArrow, ADownArrow: TBitmap);
    {$IFDEF JVCLThemesEnabled}
    procedure DrawAllBitmapClassicThemed;
    procedure DrawAllBitmapDiagonalThemed;
    procedure DrawDiagonalThemedArrows(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;
      AUpArrow, ADownArrow: TBitmap);
    {$ENDIF JVCLThemesEnabled}
    procedure Reset;

    function CompareWith(const AWidth, AHeight: Integer; const AStyle: TJvSpinButtonStyle;
      const ACustomGlyphs: Boolean): Integer;
  public
    constructor Create(AManager: TSpinButtonBitmapsManager; const AWidth, AHeight: Integer;
      const AStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean); virtual;
    destructor Destroy; override;

    procedure AddClient;
    procedure RemoveClient;

    procedure Draw(ACanvas: TCanvas; const ADown: TSpinButtonState;
      const AEnabled, AMouseInTopBtn, AMouseInBottomBtn: Boolean);
    procedure DrawGlyphs(ACanvas: TCanvas; const AState: TSpinButtonState; const Enabled: Boolean;
      AUpArrow, ADownArrow: TBitmap);

    property Width: Integer read FWidth;
    property Height: Integer read FHeight;
    property Style: TJvSpinButtonStyle read FStyle;
    property CustomGlyphs: Boolean read FCustomGlyphs;
  end;

  TSpinButtonBitmapsManager = class
  private
    FClientCount: Integer;
    FList: TList;
  protected
    function Find(const Width, Height: Integer; const AButtonStyle: TJvSpinButtonStyle;
      const ACustomGlyphs: Boolean; var Index: Integer): Boolean;
    procedure Remove(Obj: TObject);
  public
    constructor Create; virtual;
    destructor Destroy; override;

    function WantButtons(const Width, Height: Integer; const AButtonStyle: TJvSpinButtonStyle;
      const ACustomGlyphs: Boolean): TSpinButtonBitmaps;

    procedure AddClient;
    procedure RemoveClient;
  end;

var
  GSpinButtonBitmapsManager: TSpinButtonBitmapsManager = nil;

//=== Local procedures =======================================================

function SpinButtonBitmapsManager: TSpinButtonBitmapsManager;
begin
  if GSpinButtonBitmapsManager = nil then
    GSpinButtonBitmapsManager := TSpinButtonBitmapsManager.Create;
  Result := GSpinButtonBitmapsManager;
end;

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

function RemoveThousands(const AValue: string): string;
begin
  if DecimalSeparator <> ThousandSeparator then
    Result := DelChars(AValue, ThousandSeparator)
  else
    Result := AValue;
end;


//=== { TTntJvCustomSpinEdit } ==================================================

procedure TTntJvCustomSpinEdit.Change;
var
  //  OldText: string;
  OldSelStart: Integer;
begin
  { (rb) Maybe move to CMTextChanged }
  if FChanging or not HandleAllocated then
    Exit;

  FChanging := True;
  OldSelStart := SelStart;
  try
    //    OldText := inherited Text;
    try
      if not (csDesigning in ComponentState) and (coCheckOnChange in CheckOptions) then
      begin
        CheckValueRange(Value, not (coCropBeyondLimit in CheckOptions));
        SetValue(CheckValue(Value));
      end;
    except
      SetValue(CheckValue(Value));
    end;
  finally
    FChanging := False;
  end;

  SelStart := OldSelStart;

  if FOldValue <> Value then
  begin
    if Thousands and (Length(Text) mod 4 = 1) and (SelStart > 0) then
      SelStart := SelStart + 1;
    inherited Change;
    FOldValue := Value;
  end;
  //  if AnsiCompareText(inherited Text, OldText) <> 0 then
  //    inherited Change;

end;

function TTntJvCustomSpinEdit.CheckDefaultRange(CheckMax: Boolean): Boolean;
begin
  Result := (FMinValue <> 0) or (FMaxValue <> 0);
end;

function TTntJvCustomSpinEdit.CheckValue(NewValue: Extended): Extended;
begin
  Result := NewValue;
  {
    if (FMaxValue <> FMinValue) then
    begin
      if NewValue < FMinValue then
        Result := FMinValue
      else
      if NewValue > FMaxValue then
        Result := FMaxValue;
    end;
  }
  if FCheckMinValue or FCheckMaxValue then
  begin
    if FCheckMinValue and (NewValue < FMinValue) then
      Result := FMinValue;
    if FCheckMaxValue and (NewValue > FMaxValue) then
      Result := FMaxValue;
  end;
end;

function TTntJvCustomSpinEdit.CheckValueRange(NewValue: Extended; RaiseOnError: Boolean): Extended;
begin
  Result := CheckValue(NewValue);
  if (FCheckMinValue or FCheckMaxValue) and
    RaiseOnError and (Result <> NewValue) then
    raise ERangeError.CreateResFmt(@RsEOutOfRangeFloat, [FMinValue, FMaxValue]);
end;

{$IFDEF VCL}

procedure TTntJvCustomSpinEdit.CMBiDiModeChanged(var Msg: TMessage);
begin
  inherited;
  ResizeButton;
  SetEditRect;
end;

procedure TTntJvCustomSpinEdit.CMCtl3DChanged(var Msg: TMessage);
begin
  inherited;
  ResizeButton;
  SetEditRect;
end;

{$ENDIF VCL}

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

  FThousands := False; //new

  //Polaris
  FFocused := False;
  FCheckOptions := [coCheckOnChange, coCheckOnExit, coCropBeyondLimit];
  FLCheckMinValue := True;
  FLCheckMaxValue := True;
  FCheckMinValue := False;
  FCheckMaxValue := False;
  //Polaris
  ControlStyle := ControlStyle - [csSetCaption];
  FIncrement := 1.0;
  FDecimal := 2;
  FEditorEnabled := True;
  FButtonKind := bkDiagonal;
  FArrowKeys := True;
  FShowButton := True;
  RecreateButton;
end;

{$IFDEF VCL}
procedure TTntJvCustomSpinEdit.CreateParams(var Params: TCreateParams);
const
  Alignments: array [Boolean, TAlignment] of DWORD =
    ((ES_LEFT, ES_RIGHT, ES_CENTER), (ES_RIGHT, ES_LEFT, ES_CENTER));
begin
  inherited CreateParams(Params);
  // Polaris:
  //    or ES_MULTILINE
  Params.Style := Params.Style or WS_CLIPCHILDREN or
    Alignments[UseRightToLeftAlignment, FAlignment];
end;

procedure TTntJvCustomSpinEdit.CreateWnd;
begin
  inherited CreateWnd;
  SetEditRect;
end;
{$ENDIF VCL}

procedure TTntJvCustomSpinEdit.DataChanged;
var
  EditFormat: string;
  WasModified: Boolean;
begin
  if (ValueType = vtFloat) and FFocused and (FDisplayFormat <> '') then
  begin
    EditFormat := '0';
    if FDecimal > 0 then
      EditFormat := EditFormat + '.' + MakeStr('#', FDecimal);
    { Changing EditText sets Modified to false }
    WasModified := Modified;
    try
      Text := FormatFloat(EditFormat, Value);
    finally
      Modified := WasModified;
    end;
  end;
end;

function TTntJvCustomSpinEdit.DefaultDisplayFormat: string;
begin
  Result := ',0.##';
end;

destructor TTntJvCustomSpinEdit.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 TTntJvCustomSpinEdit.BoundsChanged;
var
  MinHeight: Integer;
begin
  MinHeight := GetMinHeight;
  { text edit bug: if size to less than minheight, then edit ctrl does
    not display the text }
  if Height < MinHeight then
    Height := MinHeight
  else
  begin
    ResizeButton;
    SetEditRect;
    inherited BoundsChanged;
  end;
end;

procedure TTntJvCustomSpinEdit.WMCut(var Msg: TMessage);
begin
  if FEditorEnabled and not ReadOnly then
    inherited;
end;

procedure TTntJvCustomSpinEdit.WMPaste(var Msg: TMessage);
begin
  if FEditorEnabled and not ReadOnly then
    inherited;

  { Polaris code:
  if not FEditorEnabled or ReadOnly then
    Exit;
  V := Value;
  inherited;
  try
    StrToFloat(Text);
  except
    SetValue(V);
  end;
  }
end;

procedure TTntJvCustomSpinEdit.DoEnter;
begin
  SetFocused(True);
  if AutoSelect and not (csLButtonDown in ControlState) then
    SelectAll;
  inherited DoEnter;
end;

procedure TTntJvCustomSpinEdit.DoExit;
begin
  SetFocused(False);
  try
    if not (csDesigning in ComponentState) and (coCheckOnExit in CheckOptions) then
    begin
      CheckValueRange(Value, not (coCropBeyondLimit in CheckOptions));
      SetValue(CheckValue(Value));
    end;
  except
    SetFocused(True);
    SelectAll;
    if CanFocus then
      SetFocus;
    raise;
  end;
  inherited DoExit;
end;

procedure TTntJvCustomSpinEdit.FocusKilled(NextWnd: THandle);
begin
  if ([coCropBeyondLimit, coCheckOnExit] <= CheckOptions) and
    not (csDesigning in ComponentState) then
    SetValue(CheckValue(Value));
  inherited FocusKilled(NextWnd);
end;

function TTntJvCustomSpinEdit.DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
  {$IFDEF VisualCLX} const {$ENDIF} MousePos: TPoint): Boolean;
begin
  if WheelDelta > 0 then
    UpClick(nil)
  else
    DownClick(nil);
  Result := True;
end;

procedure TTntJvCustomSpinEdit.DownClick(Sender: TObject);
var
  OldText: string;
begin
  if ReadOnly then
    DoBeepOnError
  else
  begin
    FChanging := True;
    try
      OldText := inherited Text;
      Value := Value - FIncrement;
    finally
      FChanging := False;
    end;
    if AnsiCompareText(inherited Text, OldText) <> 0 then
    begin
      Modified := True;
      Change;
    end;
    if Assigned(FOnBottomClick) then
      FOnBottomClick(Self);
  end;
end;