tntjvspin.pas

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

begin
  try
    case ValueType of
      vtFloat:
        begin
          if FDisplayFormat <> '' then
          try
            Result := StrToFloat(TextToValText(Text));
          except
            Result := FMinValue;
          end
          else
          if not TextToFloat(PChar(RemoveThousands(Text)), Result, fvExtended) then
            Result := FMinValue;
        end;
      vtHex:
        Result := StrToIntDef('$' + Text, Round(FMinValue));
    else {vtInteger}
      Result := StrToIntDef(RemoveThousands(Text), Round(FMinValue));
    end;
  except
    if ValueType = vtFloat then
      Result := FMinValue
    else
      Result := Round(FMinValue);
  end;
end;

procedure TTntJvSpinEdit.SetValue(NewValue: Extended);
var
  FloatFormat: TFloatFormat;
  WasModified: Boolean;
begin
  if Thousands then
    FloatFormat := ffNumber
  else
    FloatFormat := ffFixed;

  { Changing EditText sets Modified to false }
  WasModified := Modified;
  try
    case ValueType of
      vtFloat:
        if FDisplayFormat <> '' then
          Text := FormatFloat(FDisplayFormat, CheckValue(NewValue))
        else
          Text := FloatToStrF(CheckValue(NewValue), FloatFormat, 15, FDecimal);
      vtHex:
        if ValueType = vtHex then
          Text := IntToHex(Round(CheckValue(NewValue)), 1);
    else {vtInteger}
      //Text := IntToStr(Round(CheckValue(NewValue)));
      Text := FloatToStrF(CheckValue(NewValue), FloatFormat, 15, 0);
    end;
    DataChanged;
  finally
    Modified := WasModified;
  end;
end;

//=== { TJvUpDown } ==========================================================

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

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

procedure TJvUpDown.Resize;
begin
  if Width <> DefBtnWidth then
    Width := DefBtnWidth
  else
    inherited Resize;
end;

{$IFDEF VCL}

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

procedure TJvUpDown.WMHScroll(var Msg: TWMHScroll);
begin
  ScrollMessage(TWMVScroll(Msg));
end;

procedure TJvUpDown.WMVScroll(var Msg: TWMVScroll);
begin
  ScrollMessage(Msg);
end;

{$ENDIF VCL}

{$IFDEF VisualCLX}
procedure TJvUpDown.Click(Button: TUDBtnType);
var
  Pos: Integer;
begin
  if not FChanging then
  begin
    FChanging := True;
    try
      Pos := Position;
      UpdatePosition(0);
    finally
      FChanging := False;
    end;
    if Pos < 0 then
      inherited Click(btPrev)
    else
      inherited Click(btNext)
  end;
end;
{$ENDIF VisualCLX}

//=== { TSpinButtonBitmaps } =================================================

procedure TSpinButtonBitmaps.AddClient;
begin
  Inc(FClientCount);
end;

function TSpinButtonBitmaps.CompareWith(const AWidth, AHeight: Integer;
  const AStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean): Integer;
begin
  // used by the binary search
  Result := Self.Width - AWidth;
  if Result = 0 then
  begin
    Result := Self.Height - AHeight;
    if Result = 0 then
    begin
      Result := Ord(Self.Style) - Ord(AStyle);
      if Result = 0 then
        Result := Ord(Self.CustomGlyphs) - Ord(ACustomGlyphs);
    end;
  end;
end;

constructor TSpinButtonBitmaps.Create(AManager: TSpinButtonBitmapsManager;
  const AWidth, AHeight: Integer; const AStyle: TJvSpinButtonStyle; const ACustomGlyphs: Boolean);
begin
  inherited Create;
  FManager := AManager;
  FWidth := AWidth;
  FHeight := AHeight;
  FStyle := AStyle;
  FCustomGlyphs := ACustomGlyphs;

  FTopDownBtn := TBitmap.Create;
  FBottomDownBtn := TBitmap.Create;
  FNotDownBtn := TBitmap.Create;
  FDisabledBtn := TBitmap.Create;
  {$IFDEF JVCLThemesEnabled}
  FTopHotBtn := TBitmap.Create;
  FBottomHotBtn := TBitmap.Create;
  {$ENDIF JVCLThemesEnabled}

  DrawAllBitmap;
end;

destructor TSpinButtonBitmaps.Destroy;
begin
  FManager.Remove(Self);

  FTopDownBtn.Free;
  FBottomDownBtn.Free;
  FNotDownBtn.Free;
  FDisabledBtn.Free;
  {$IFDEF JVCLThemesEnabled}
  FTopHotBtn.Free;
  FBottomHotBtn.Free;
  {$ENDIF JVCLThemesEnabled}

  inherited Destroy;
end;

procedure TSpinButtonBitmaps.Draw(ACanvas: TCanvas;
  const ADown: TSpinButtonState; const AEnabled, AMouseInTopBtn, AMouseInBottomBtn: Boolean);
begin
  if FResetOnDraw then
  begin
    DrawAllBitmap;
    FResetOnDraw := False;
  end;

  with ACanvas do
    if not AEnabled then
      Draw(0, 0, FDisabledBtn)
    else
      case ADown of
        sbNotDown:
          {$IFDEF JVCLThemesEnabled}
          if FIsThemed then
          begin
            if AMouseInTopBtn then
              Draw(0, 0, FTopHotBtn)
            else
            if AMouseInBottomBtn then
              Draw(0, 0, FBottomHotBtn)
            else
              Draw(0, 0, FNotDownBtn);
          end
          else
          {$ENDIF JVCLThemesEnabled}
            Draw(0, 0, FNotDownBtn);
        sbTopDown:
          Draw(0, 0, FTopDownBtn);
        sbBottomDown:
          Draw(0, 0, FBottomDownBtn);
      end;
end;

procedure TSpinButtonBitmaps.DrawAllBitmap;
begin
  {$IFDEF JVCLThemesEnabled}
  FIsThemed := ThemeServices.ThemesEnabled;
  if FIsThemed then
  begin
    if FStyle = sbsClassic then
      DrawAllBitmapClassicThemed
    else
      DrawAllBitmapDiagonalThemed;
    Exit;
  end;
  {$ENDIF JVCLThemesEnabled}

  DrawBitmap(FTopDownBtn, sbTopDown, True);
  DrawBitmap(FBottomDownBtn, sbBottomDown, True);
  DrawBitmap(FNotDownBtn, sbNotDown, True);
  DrawBitmap(FDisabledBtn, sbNotDown, False);
end;

{$IFDEF JVCLThemesEnabled}

procedure TSpinButtonBitmaps.DrawAllBitmapClassicThemed;
type
  TButtonPartState = (bpsNormal, bpsHot, bpsPressed, bpsDisabled);
const
  CDetails: array [Boolean, TButtonPartState] of TThemedSpin = (
    (tsUpNormal, tsUpHot, tsUpPressed, tsUpDisabled),
    (tsDownNormal, tsDownHot, tsDownPressed, tsDownDisabled)
    );
var
  TopRect, BottomRect: TRect;
  TopRegion_TopAbove, BottomRegion_TopAbove: HRGN;
  TopRegion_BottomAbove, BottomRegion_BottomAbove: HRGN;

  procedure ConstructThemedButton(ABitmap: TBitmap; const AUpState, ADownState: TButtonPartState);
  var
    Details: TThemedElementDetails;
  begin
    with ABitmap do
    begin
      Height := Self.Height;
      Width := Self.Width;

      with Canvas do
      begin
        // Select only top button
        if AUpState = bpsNormal then
          SelectClipRgn(Handle, TopRegion_BottomAbove)
        else
          SelectClipRgn(Handle, TopRegion_TopAbove);
        // Copy top button
        Details := ThemeServices.GetElementDetails(CDetails[False, AUpState]);
        ThemeServices.DrawElement(Handle, Details, TopRect);
        // Select only bottom button
        if AUpState = bpsNormal then
          SelectClipRgn(Handle, BottomRegion_BottomAbove)
        else
          SelectClipRgn(Handle, BottomRegion_TopAbove);
        // Copy bottom button
        Details := ThemeServices.GetElementDetails(CDetails[True, ADownState]);
        ThemeServices.DrawElement(Handle, Details, BottomRect);
        // Remove clipping restriction
        SelectClipRgn(Handle, 0);
      end;
    end;
  end;

begin
  TopRect := Rect(0, 0, Width, Height div 2);
  InflateRect(TopRect, 1, 1);

  BottomRect := Rect(0, TopRect.Bottom, Width, Height);
  InflateRect(BottomRect, 1, 1);

  { Construct the regions (needed because the up & down buttons overlap
    each other) }
  with TopRect do
  begin
    TopRegion_TopAbove := CreateRectRgn(Left, Top, Right, Bottom + 1);
    TopRegion_BottomAbove := CreateRectRgn(Left, Top, Right, Bottom);
  end;
  with BottomRect do
  begin
    BottomRegion_TopAbove := CreateRectRgn(Left, Top + 1, Right, Bottom);
    BottomRegion_BottomAbove := CreateRectRgn(Left, Top, Right, Bottom);
  end;
  try
    { Draw the buttons }
    ConstructThemedButton(FTopDownBtn, bpsPressed, bpsNormal);
    ConstructThemedButton(FBottomDownBtn, bpsNormal, bpsPressed);
    ConstructThemedButton(FNotDownBtn, bpsNormal, bpsNormal);
    ConstructThemedButton(FTopHotBtn, bpsHot, bpsNormal);
    ConstructThemedButton(FBottomHotBtn, bpsNormal, bpsHot);
    ConstructThemedButton(FDisabledBtn, bpsDisabled, bpsDisabled);
  finally
    DeleteObject(TopRegion_TopAbove);
    DeleteObject(BottomRegion_TopAbove);
    DeleteObject(TopRegion_BottomAbove);
    DeleteObject(BottomRegion_BottomAbove);
  end;
end;

procedure TSpinButtonBitmaps.DrawAllBitmapDiagonalThemed;
type
  TButtonPartState = (bpsNormal, bpsHot, bpsPressed, bpsDisabled);
const
  CDetails: array [TButtonPartState] of TThemedButton =
    (tbPushButtonNormal, tbPushButtonHot, tbPushButtonPressed, tbPushButtonDisabled);
var
  TemplateButtons: array [TButtonPartState] of TBitmap;
  ThemeColors: array [0..2] of Cardinal;
  ButtonRect: TRect;
  PaintRect: TRect;
  TopRegion, BottomRegion: HRGN;
  UpBitmap, DownBitmap: TBitmap;

  procedure ConstructThemedButton(ABitmap: TBitmap; const AUpState, ADownState: TButtonPartState);
  begin
    with ABitmap do
    begin
      Height := Self.Height;
      Width := Self.Width;

      with Canvas do
      begin
        { Select only top button }
        SelectClipRgn(Handle, TopRegion);
        { Copy top button }
        ABitmap.Canvas.Draw(0, 0, TemplateButtons[AUpState]);
        { Select only bottom button }
        SelectClipRgn(Handle, BottomRegion);
        { Copy bottom button }
        ABitmap.Canvas.Draw(0, 0, TemplateButtons[ADownState]);
        { Remove clipping restriction }
        SelectClipRgn(Handle, 0);

        { Draw diagonal }
        Pen.Color := ThemeColors[0];
        MoveTo(PaintRect.Left, PaintRect.Bottom - 2);
        LineTo(PaintRect.Right - 1, PaintRect.Top - 1);

        Pen.Color := ThemeColors[1];
        MoveTo(PaintRect.Right - 1, PaintRect.Top);
        LineTo(PaintRect.Right - 1, PaintRect.Top);
        LineTo(PaintRect.Left, PaintRect.Bottom - 1);

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

        if not CustomGlyphs then
          DrawDiagonalThemedArrows(ABitmap.Canvas, sbNotDown,
            AUpState <> bpsDisabled, UpBitmap, DownBitmap);
      end;
    end;
  end;

var
  ptButton: array [0..2] of TPoint;
  State: TButtonPartState;
  Details: TThemedElementDetails;
begin
  TemplateButtons[bpsNormal] := TBitmap.Create;
  TemplateButtons[bpsHot] := TBitmap.Create;
  TemplateButtons[bpsPressed] := TBitmap.Create;
  TemplateButtons[bpsDisabled] := TBitmap.Create;
  try
    ButtonRect := Bounds(0, 0, Width, Height);
    PaintRect := ButtonRect;
    InflateRect(ButtonRect, 1, 1);
    InflateRect(PaintRect, -1, -1);
    { Init templates }
    for State := Low(TButtonPartState) to High(TButtonPartState) do
      with TemplateButtons[State] do
      begin
        Height := Self.Height;
        Width := Self.Width;
        Details := ThemeServices.GetElementDetails(CDetails[State]);
        ThemeServices.DrawElement(Canvas.Handle, Details, ButtonRect);
      end;

    { Init diagonal colors }
    Details := ThemeServices.GetElementDetails(tbPushButtonNormal);
    with Details do
    begin
      GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_EDGELIGHTCOLOR, ThemeColors[0]);
      GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_BORDERCOLORHINT, ThemeColors[1]);
      GetThemeColor(ThemeServices.Theme[Element], Part, State, TMT_EDGESHADOWCOLOR, ThemeColors[2]);
    end;

    UpBitmap := nil;
    DownBitmap := nil;
    try
      if not CustomGlyphs then
      begin
        UpBitmap := TBitmap.Create;
        UpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);
        UpBitmap.Transparent := True;
        DownBitmap := TBitmap.Create;
        DownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);
        DownBitmap.Transparent := True;
      end;

      { Init regions, needed to draw the triangles }
      ptButton[0] := Point(ButtonRect.Left, ButtonRect.Bottom);
      ptButton[1] := Point(ButtonRect.Left, ButtonRect.Top);
      ptButton[2] := Point(ButtonRect.Right, ButtonRect.Top);
      TopRegion := CreatePolygonRgn(ptButton, 3, WINDING);
      ptButton[0] := Point(ButtonRect.Right, ButtonRect.Top);
      ptButton[1] := Point(ButtonRect.Right, ButtonRect.Bottom);
      ptButton[2] := Point(ButtonRect.Left, ButtonRect.Bottom);
      BottomRegion := CreatePolygonRgn(ptButton, 3, WINDING);
      try
        { Draw the buttons }
        ConstructThemedButton(FTopDownBtn, bpsPressed, bpsNormal);
        ConstructThemedButton(FBottomDownBtn, bpsNormal, bpsPressed);
        ConstructThemedButton(FNotDownBtn, bpsNormal, bpsNormal);
        ConstructThemedButton(FTopHotBtn, bpsHot, bpsNormal);
        ConstructThemedButton(FBottomHotBtn, bpsNormal, bpsHot);
        ConstructThemedButton(FDisabledBtn, bpsDisabled, bpsDisabled);
      finally
        DeleteObject(TopRegion);
        DeleteObject(BottomRegion);
      end;
    fin