tntjvspeedbutton.pas

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

begin
  with Message do
    if IsWideCharAccel(CharCode, Caption) and Enabled and Visible and
      (Parent <> nil) and Parent.Showing then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TTntJvCustomSpeedButton0.ActionChange(Sender: TObject;
  CheckDefaults: Boolean);
begin
  TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults);
end;

function TTntJvCustomSpeedButton0.WantKey(Key: Integer; Shift: TShiftState;
  const KeyText: WideString): Boolean;
begin
  Result := IsAccel(Key, Caption) and Enabled and (ssAlt in Shift);
  if Result then
    Click
  else
    inherited WantKey(Key, Shift, KeyText);
end;

procedure TTntJvCustomSpeedButton0.EnabledChanged;
var
  State: TJvButtonState;
begin
  inherited EnabledChanged;
  if Enabled then
  begin
    if Flat then
      State := rbsInactive
    else
      State := rbsUp;
  end
  else
    State := rbsDisabled;
  FGlyph.CreateButtonGlyph(State);
  { Resync MouseOver }
  UpdateTracking;
  Repaint;
end;

procedure TTntJvCustomSpeedButton0.FontChanged;
begin
  UpdateTrackFont(HotTrackFont, Font, HotTrackFontOptions);
  Invalidate;
end;

procedure TTntJvCustomSpeedButton0.MouseEnter(Control: TControl);
var
  NeedRepaint: Boolean;
begin
  if csDesigning in ComponentState then
    Exit;
  if not MouseOver and Enabled then
  begin
    { Don't draw a border if DragMode <> dmAutomatic since this button is meant to
      be used as a dock client. }
    NeedRepaint :=
      {$IFDEF JVCLThemesEnabled}
      ThemeServices.ThemesEnabled or
      {$ENDIF JVCLThemesEnabled}
      FHotTrack or (FFlat and Enabled and (DragMode <> dmAutomatic) and (GetCapture = NullHandle));

    NeedRepaint :=  NeedRepaint
{$IFDEF VCL}
{$IFDEF COMPILER6_UP}
     and not Mouse.IsDragging
{$ELSE}
     and not KeyPressed(VK_LBUTTON)
{$ENDIF COMPILER6_UP}
{$ENDIF VCL}
{$IFDEF VisualCLX}
     and not DragActivated
{$ENDIF VisualCLX}
      ;

    inherited MouseEnter(Control); // set MouseOver
    { Windows XP introduced hot states also for non-flat buttons. }
    if NeedRepaint then
      Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.MouseLeave(Control: TControl);
var
  NeedRepaint: Boolean;
begin
  if MouseOver and Enabled  then
  begin
    NeedRepaint :=
      {$IFDEF JVCLThemesEnabled}
      { Windows XP introduced hot states also for non-flat buttons. }
      ThemeServices.ThemesEnabled or
      {$ENDIF JVCLThemesEnabled}
      HotTrack or (FFlat and Enabled and not FDragging and (GetCapture = NullHandle));

    NeedRepaint :=  NeedRepaint
{$IFDEF VCL}
{$IFDEF COMPILER6_UP}
     and not Mouse.IsDragging
{$ELSE}
     and not KeyPressed(VK_LBUTTON)
{$ENDIF COMPILER6_UP}
{$ENDIF VCL}
{$IFDEF VisualCLX}
     and not DragActivated
{$ENDIF VisualCLX}
      ;

    inherited MouseLeave(Control); // set MouseOver
    if NeedRepaint   then
      Invalidate;
  end;
end;

{$IFDEF VCL}
procedure TTntJvCustomSpeedButton0.CMSysColorChange(var Msg: TMessage);
begin
  FGlyph.Invalidate;
  Invalidate;
end;
{$ENDIF VCL}

procedure TTntJvCustomSpeedButton0.TextChanged;
begin
  Invalidate;
end;

procedure TTntJvCustomSpeedButton0.VisibleChanged;
begin
  inherited VisibleChanged;
  if Visible then
    UpdateTracking;
end;

constructor TTntJvCustomSpeedButton0.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ParentColor := False;
  Color := clBtnFace;
  FHotTrack := False;
  FHotTrackFont := TFont.Create;
  FHotTrackFontOptions := DefaultTrackFontOptions;
  {Inserted by (ag) 2004-09-04}
  FHotTrackOptions := TJvSpeedButtonHotTrackOptions.Create;
  {Insert End}
  FFontSave := TFont.Create;
  SetBounds(0, 0, 25, 25);
  ControlStyle := [csCaptureMouse, csOpaque, csDoubleClicks];
  ControlStyle := ControlStyle + [csReplicatable];
  FInactiveGrayed := True;
  FGlyph := TTntJvxButtonGlyph.Create;
  FGlyph.GrayNewStyle := True;
  ParentFont := True;
  ParentShowHint := False;
  ShowHint := True;
  FSpacing := 1;
  FMargin := -1;
  FInitRepeatPause := 500;
  FRepeatPause := 100;
  FStyle := bsAutoDetect;
  FLayout := blGlyphTop;
  FMarkDropDown := True;
  FDoubleBuffered := True;
  Inc(ButtonCount);
end;

destructor TTntJvCustomSpeedButton0.Destroy;
begin
  {Inserted by (ag) 2004-09-04}
  FHotTrackOptions.Free;
  {Insert End}
  FGlyph.Free;
  Dec(ButtonCount);
  if FRepeatTimer <> nil then
    FRepeatTimer.Free;
  FHotTrackFont.Free;
  FFontSave.Free;
  inherited Destroy;
end;

procedure TTntJvCustomSpeedButton0.DoMouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  if FDragging and (Button = mbLeft) then
  begin
    FDragging := False;
    DoClick := (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight);
    if FGroupIndex = 0 then
    begin
      FState := rbsUp;
      { Calling Click might open a new window or something which will remove
        the focus; if the new window is modal then UpdateTracking won't be
        called until the window is closed, thus: }
      {$IFDEF VCL}
      Perform(CM_MOUSELEAVE, 0, 0);
      {$ENDIF VCL}
      {$IFDEF VisualCLX}
      MouseLeave(Self);
      {$ENDIF VisualCLX}
      { Even if the mouse is not in the control (DoClick=False) we must redraw
        the image, because it must change from hot -> normal }
      //if not DoClick then
        Invalidate;
    end
    else
    if DoClick then
    begin
      SetDown(not FDown);
      if FDown then
        Repaint;
    end
    else
    begin
      if FDown then
        FState := rbsExclusive;
      Repaint;
    end;
    if DoClick and not FMenuTracking then
    begin
      Click;
    end;
  end;
  { After a Click call a lot can happen thus check whether we're hot or not: }
  UpdateTracking;
end;

function TTntJvCustomSpeedButton0.GetAlignment: TAlignment;
begin
  Result := FGlyph.Alignment;
end;

function TTntJvCustomSpeedButton0.GetDropDownMenuPos: TPoint;
begin
  if Assigned(FDropDownMenu) then
  begin
    if MenuPosition = dmpBottom then
    begin
      case FDropDownMenu.Alignment of
        paLeft:
          Result := Point(-1, Height);
        paRight:
          Result := Point(Width + 1, Height);
      else {paCenter}
        Result := Point(Width div 2, Height);
      end;
    end
    else { dmpRight }
    begin
      case FDropDownMenu.Alignment of
        paLeft:
          Result := Point(Width, -1);
        paRight:
          Result := Point(-1, -1);
      else {paCenter}
        Result := Point(Width div 2, Height);
      end;
    end;
  end
  else
    Result := Point(0, 0);
end;

function TTntJvCustomSpeedButton0.GetGrayNewStyle: Boolean;
begin
  Result := FGlyph.GrayNewStyle;
end;

function TTntJvCustomSpeedButton0.GetWordWrap: Boolean;
begin
  Result := FGlyph.WordWrap;
end;

procedure TTntJvCustomSpeedButton0.Loaded;
var
  LState: TJvButtonState;
begin
  inherited Loaded;

  if Enabled then
  begin
    if Flat then
      LState := rbsInactive
    else
      LState := rbsUp;
  end
  else
    LState := rbsDisabled;
  FGlyph.CreateButtonGlyph(LState);
end;

procedure TTntJvCustomSpeedButton0.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  P: TPoint;
  {$IFDEF VCL}
  Msg: TMsg;
  {$ENDIF VCL}
begin
  try
    if FMenuTracking then
      Exit;
    inherited MouseDown(Button, Shift, X, Y);
    if not MouseOver and Enabled then
    begin
      MouseOver := True;
      Invalidate {Repaint};
    end;
    if (Button = mbLeft) and Enabled {and not (ssDouble in Shift)} then
    begin
      if not FDown then
      begin
        FState := rbsDown;
        Invalidate {Repaint};
      end;
      FDragging := True;
      FMenuTracking := True;
      try
        P := GetDropDownMenuPos;
        if CheckMenuDropDown(PointToSmallPoint(P), False) then
          DoMouseUp(Button, Shift, X, Y);
        {$IFDEF VCL}
        if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then
        begin
          if (Msg.Message = WM_LBUTTONDOWN) or (Msg.Message = WM_LBUTTONDBLCLK) then
          begin
            P := ScreenToClient(Msg.Pt);
            if (P.X >= 0) and (P.X < ClientWidth) and (P.Y >= 0) and (P.Y <= ClientHeight) then
              KillMessage(Windows.HWND_DESKTOP, Msg.Message);
          end;
        end;
        {$ENDIF VCL}
      finally
        FMenuTracking := False;
      end;
      if FAllowTimer then
      begin
        if FRepeatTimer = nil then
          FRepeatTimer := TTimer.Create(Self);
        FRepeatTimer.Interval := InitPause;
        FRepeatTimer.OnTimer := TimerExpired;
        FRepeatTimer.Enabled := True;
      end;
    end;
  finally
    {$IFDEF VisualCLX}
     // (ahuser) Maybe we should remove the WM_RBUTTONDOWN code and make this
     // code available for VCL and VisualCLX.
    if Button = mbRight then
      UpdateTracking;
    {$ENDIF VisualCLX}
  end;
end;

procedure TTntJvCustomSpeedButton0.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TJvButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  begin
    if not FDown then
      NewState := rbsUp
    else
      NewState := rbsExclusive;
    if (X >= 0) and (X < ClientWidth) and (Y >= 0) and (Y <= ClientHeight) then
      if FDown then
        NewState := rbsExclusive
      else
        NewState := rbsDown;
    if NewState <> FState then
    begin
      FState := NewState;
      Repaint;
    end;
  end;
end;

procedure TTntJvCustomSpeedButton0.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  DoMouseUp(Button, Shift, X, Y);
  if FRepeatTimer <> nil then
    FRepeatTimer.Enabled := False;
  {$IFDEF VisualCLX}
  // (ahuser) Maybe we should remove the WM_RBUTTONUP code and make this
  // code available for VCL and VisualCLX.
  if Button = mbRight then
    UpdateTracking;
  {$ENDIF VisualCLX}
end;

procedure TTntJvCustomSpeedButton0.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = DropDownMenu) and (Operation = opRemove) then
    DropDownMenu := nil;
end;

procedure TTntJvCustomSpeedButton0.Paint;
var
  PaintRect: TRect;
  State: TJvButtonState;
  OldPenColor:TColor;
  Offset: TPoint;
  {$IFDEF JVCLThemesEnabled}
  Button: TThemedButton;
  ToolButton: TThemedToolBar;
  Details: TThemedElementDetails;
  {$ENDIF JVCLThemesEnabled}
begin
  if not Enabled {and not (csDesigning in ComponentState)} then
  begin
    FState := rbsDisabled;
    FDragging := False;
  end
  else
  if FState = rbsDisabled then
    if FDown and (GroupIndex <> 0) then
      FState := rbsExclusive
    else
      FState := rbsUp;

  if FFlat and not MouseOver and not (csDesigning in ComponentState) then
    { rbsInactive : flat and not 'mouse in control', thus
        - picture might be painted gray
        - no border, unless button is exclusive
    }
    State := rbsInactive
  else
    State := FState;

  PaintRect := Rect(0, 0, Width, Height);

  {$IFDEF JVCLThemesEnabled}
  if ThemeServices.ThemesEnabled then
  begin
    if FTransparent then
      CopyParentImage(Self, Canvas)
    else
    begin
      if not DoubleBuffered then
        PerformEraseBackground(Self, Canvas.Handle) // uses Control.Left/Top as Offset