tntjvspeedbutton.pas

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

      else
        PerformEraseBackground(Self, Canvas.Handle, Point(0, 0)); // we are drawing into a bitmap
    end;

    if (MouseOver or FDragging) and HotTrack then
      Canvas.Font := Self.HotTrackFont
    else
      Canvas.Font := Self.Font;

    if not Enabled then
      Button := tbPushButtonDisabled
    else
    if FState in [rbsDown, rbsExclusive] then
      Button := tbPushButtonPressed
    else
    if MouseOver or FDragging then
      Button := tbPushButtonHot
    else
      Button := tbPushButtonNormal;

    ToolButton := ttbToolbarDontCare;
    if FFlat then
    begin
      case Button of
        tbPushButtonDisabled:
          ToolButton := ttbButtonDisabled;
        tbPushButtonPressed:
          ToolButton := ttbButtonPressed;
        tbPushButtonHot:
          ToolButton := ttbButtonHot;
        tbPushButtonNormal:
          ToolButton := ttbButtonNormal;
      end;
    end;

    if ToolButton = ttbToolbarDontCare then
    begin
      Details := ThemeServices.GetElementDetails(Button);
      ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
      PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect);
    end
    else
    begin
      Details := ThemeServices.GetElementDetails(ToolButton);
      ThemeServices.DrawElement(Canvas.Handle, Details, PaintRect);
      PaintRect := ThemeServices.ContentRect(Canvas.Handle, Details, PaintRect);
    end;

    if Button = tbPushButtonPressed then
      // A pressed speed Button has a white text. This applies however only to flat buttons.
      //if ToolButton <> ttbToolbarDontCare then
      //  Canvas.Font.Color := clHighlightText;
      Offset := Point(1, 0)
    else
      Offset := Point(0, 0);

    { Check whether the image need to be painted gray.. }
    if (FState = rbsDisabled) or not FInactiveGrayed then
      { .. do not paint gray image }
      State := FState;

    PaintImage(Canvas, PaintRect, Offset, State,
      FMarkDropDown and Assigned(FDropDownMenu));
  end
  else
  {$ENDIF JVCLThemesEnabled}
  begin
    with Canvas do
    begin
      if FTransparent then
        CopyParentImage(Self, Canvas)
      else
      begin
        if Flat then
          Brush.Color := TWinControlAccess(Parent).Color
        else
          Brush.Color := Self.Color;
        Brush.Style := bsSolid;
        FillRect(PaintRect);
      end;
      if (State <> rbsInactive) or (FState = rbsExclusive) then
        PaintRect := DrawButtonFrame(Canvas, PaintRect,
          FState in [rbsDown, rbsExclusive], FFlat, FStyle, Color)
      else
      if FFlat then
        InflateRect(PaintRect, -2, -2);
    end;
    if (FState = rbsExclusive) and not Transparent and
      (not FFlat or (State = rbsInactive)) then
    begin
      Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
      InflateRect(PaintRect, 1, 1);
      Canvas.FillRect(PaintRect);
      InflateRect(PaintRect, -1, -1);
    end;
    if FState in [rbsDown, rbsExclusive] then
      Offset := Point(1, 1)
    else
      Offset := Point(0, 0);

    { Check whether the image need to be painted gray.. }
    if (FState = rbsDisabled) or not FInactiveGrayed then
      { .. do not paint gray image }
      State := FState;

    if ((HotTrackOptions.Enabled and Down) or (MouseOver or FDragging)) and HotTrack then
    begin
      Canvas.Font := Self.HotTrackFont;
      {Inserted by (ag) 2004-09-04}
      if HotTrackOptions.Enabled then
        begin
          if Down then  //fixed bug: memory leak
            Canvas.Brush.Bitmap := GetBrushPattern(HotTrackOptions.Color, clWindow)
          else
          begin
            Canvas.Brush.Color := HotTrackOptions.Color;
            Canvas.Brush.Style := bsSolid;
          end;
          {Inserted by (dejoy) 2005-05-20}
          if HotTrackOptions.FrameVisible then
          begin
            OldPenColor := Canvas.Pen.Color;
            Canvas.Pen.Color := HotTrackOptions.FrameColor;
            Canvas.Rectangle(0, 0, Width, Height);
            Canvas.Pen.Color := OldPenColor;
          end
          else
          begin
            PaintRect := ClientRect;
            if Flat then
              InflateRect(PaintRect,-1,-1)
            else
              InflateRect(PaintRect,-1,-2);
            Canvas.FillRect(PaintRect);
          end;
         {Insert End by (dejoy)}
          if Down then
            Canvas.Brush.Bitmap := nil; // release bitmap
        end;
      {Insert End}
    end else
      Canvas.Font := Self.Font;
    PaintImage(Canvas, PaintRect, Offset, State,
      FMarkDropDown and Assigned(FDropDownMenu));
  end;
end;

procedure TTntJvCustomSpeedButton0.SetAlignment(Value: TAlignment);
begin
  if Alignment <> Value then
  begin
    FGlyph.Alignment := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetAllowAllUp(Value: Boolean);
begin
  if FAllowAllUp <> Value then
  begin
    FAllowAllUp := Value;
    UpdateExclusive;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetAllowTimer(Value: Boolean);
begin
  FAllowTimer := Value;
  if not FAllowTimer and (FRepeatTimer <> nil) then
  begin
    FRepeatTimer.Enabled := False;
    FRepeatTimer.Free;
    FRepeatTimer := nil;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetDown(Value: Boolean);
begin
  if FGroupIndex = 0 then
    Value := False;
  if Value <> FDown then
  begin
    if FDown and not FAllowAllUp then
      Exit;
    FDown := Value;
    if Value then
    begin
      if FState = rbsUp then
        Invalidate;
      FState := rbsExclusive;
    end
    else
    begin
      FState := rbsUp;
    end;
    Repaint;
    if Value then
      UpdateExclusive;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetDropdownMenu(Value: TPopupMenu);
begin
  FDropDownMenu := Value;
  if Value <> nil then
    Value.FreeNotification(Self);
  if FMarkDropDown then
    Invalidate;
end;

procedure TTntJvCustomSpeedButton0.SetFlat(Value: Boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetGrayNewStyle(const Value: Boolean);
begin
  if GrayNewStyle <> Value then
  begin
    FGlyph.GrayNewStyle := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetGroupIndex(Value: Integer);
begin
  if FGroupIndex <> Value then
  begin
    FGroupIndex := Value;
    UpdateExclusive;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetHotTrackFont(Value: TFont);
begin
  if (FHotTrackFont<>Value) and (Value <> nil) then
    FHotTrackFont.Assign(Value);
end;

procedure TTntJvCustomSpeedButton0.SetHotTrackFontOptions(Value: TJvTrackFontOptions);
begin
  if FHotTrackFontOptions <> Value then
  begin
    FHotTrackFontOptions := Value;
    UpdateTrackFont(HotTrackFont, Font, FHotTrackFontOptions);
  end;
end;

procedure TTntJvCustomSpeedButton0.SetHotTrackOptions(Value: TJvHotTrackOptions);
begin
  if (FHotTrackOptions <> Value) and (Value <> nil) then
    FHotTrackOptions.Assign(Value);
end;

procedure TTntJvCustomSpeedButton0.SetInactiveGrayed(Value: Boolean);
begin
  if Value <> FInactiveGrayed then
  begin
    FInactiveGrayed := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetLayout(Value: TButtonLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetMarkDropDown(Value: Boolean);
begin
  if Value <> FMarkDropDown then
  begin
    FMarkDropDown := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetStyle(Value: TButtonStyle);
begin
  if Style <> Value then
  begin
    FStyle := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetTransparent(Value: Boolean);
begin
  if Value <> FTransparent then
  begin
    FTransparent := Value;
    Invalidate;
  end;
end;

procedure TTntJvCustomSpeedButton0.SetWordWrap(Value: Boolean);
begin
  if Value <> WordWrap then
  begin
    FGlyph.WordWrap := Value;
    Invalidate;
  end;
end;

function TTntJvCustomSpeedButton0.GetHotTrack: Boolean;
begin
  Result := FHotTrack;
end;

function TTntJvCustomSpeedButton0.GetHotTrackFont: TFont;
begin
  Result := FHotTrackFont;
end;

function TTntJvCustomSpeedButton0.GetHotTrackFontOptions: TJvTrackFontOptions;
begin
  Result := FHotTrackFontOptions;
end;

function TTntJvCustomSpeedButton0.GetHotTrackOptions: TJvHotTrackOptions;
begin
  Result := FHotTrackOptions;
end;

procedure TTntJvCustomSpeedButton0.SetHotTrack(Value: Boolean);
begin
  if FHotTrack <> Value then
  begin
    FHotTrack := Value;
  end;
end;

procedure TTntJvCustomSpeedButton0.TimerExpired(Sender: TObject);
begin
  FRepeatTimer.Interval := RepeatInterval;
  if (FState = rbsDown) and MouseCapture then
  try
    Click;
  except
    FRepeatTimer.Enabled := False;
    raise;
  end;
end;

procedure TTntJvCustomSpeedButton0.UpdateExclusive;
var
  Msg: TCMButtonPressed;
begin
  if (FGroupIndex <> 0) and (Parent <> nil) then
  begin
    Msg.Msg := CM_JVBUTTONPRESSED;
    Msg.Index := FGroupIndex;
    Msg.Control := Self;
    Msg.Result := 0;
    Parent.Broadcast(Msg);
  end;
end;

procedure TTntJvCustomSpeedButton0.UpdateTracking;
var
  P: TPoint;
  NewValue: Boolean;
begin
  GetCursorPos(P);
  NewValue := Enabled and (FindDragTarget(P, True) = Self) and IsForegroundTask;
  if MouseOver <> NewValue then
    {$IFDEF VCL}
    if NewValue then
      Perform(CM_MOUSEENTER, 0, 0)
    else
      Perform(CM_MOUSELEAVE, 0, 0);
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    if NewValue then
      MouseEnter(Self)
    else
      MouseLeave(Self);
    {$ENDIF VisualCLX}
end;

{$IFDEF VCL}
procedure TTntJvCustomSpeedButton0.WMLButtonDblClk(var Msg: TWMLButtonDown);
begin
  if not FMenuTracking then
  begin
    inherited;
    if FDown then
      DblClick;
  end;
end;
{$ENDIF VCL}

{$IFDEF VisualCLX}
procedure TTntJvCustomSpeedButton0.DblClick;
begin
  if not FMenuTracking then
  begin
    inherited DblClick;
    if FDown then
      DblClick;
  end;
end;
{$ENDIF VisualCLX}

{$IFDEF VCL}
procedure TTntJvCustomSpeedButton0.WMPaint(var Msg: TWMPaint);
var
  MemBitmap: HBitmap;
  SaveBitmap: HBitmap;
  MemDC: HDC;
  Index: Integer;
  DC: HDC;
begin
  if not DoubleBuffered then
    inherited
  else
  if Msg.DC <> 0 then
  begin
    MemBitmap := CreateCompatibleBitmap(Msg.DC, Width, Height);
    MemDC := CreateCompatibleDC(Msg.DC);
    SaveBitmap := SelectObject(MemDC, MemBitmap);
    try
      DC := Msg.DC;
      Index := SaveDC(DC);
      try
        Msg.DC := MemDC;