jvspeedbutton.pas

East make Tray Icon in delphi

end;

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

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

procedure TJvCustomSpeedButton.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));

    inherited MouseEnter(Control); // set MouseOver

    { Windows XP introduced hot states also for non-flat buttons. }
    if NeedRepaint then
      Repaint;
  end;
end;

procedure TJvCustomSpeedButton.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);

    inherited MouseLeave(Control); // set MouseOver

    if NeedRepaint then
      Repaint;
  end;
end;

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

procedure TJvCustomSpeedButton.TextChanged;
begin
  Invalidate;
end;

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

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

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

procedure TJvCustomSpeedButton.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 TJvCustomSpeedButton.GetAlignment: TAlignment;
begin
  Result := TJvxButtonGlyph(FGlyph).Alignment;
end;

function TJvCustomSpeedButton.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 TJvCustomSpeedButton.GetGrayNewStyle: Boolean;
begin
  Result := TJvxButtonGlyph(FGlyph).GrayNewStyle;
end;

function TJvCustomSpeedButton.GetWordWrap: Boolean;
begin
  Result := TJvxButtonGlyph(FGlyph).WordWrap;
end;

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

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

procedure TJvCustomSpeedButton.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 TJvCustomSpeedButton.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 TJvCustomSpeedButton.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 TJvCustomSpeedButton.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (AComponent = DropDownMenu) and (Operation = opRemove) then
    DropDownMenu := nil;
end;

procedure TJvCustomSpeedButton.Paint;
var
  PaintRect: TRect;
  LState: TJvButtonState;
  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
    }
    LState := rbsInactive
  else
    LState := FState;

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

  {$IFDEF JVCLThemesEnabled}
  if ThemeServices.ThemesEnabled then
  begin
    if FTransparent then
      CopyParentImage(Self, Canvas)
    else
      PerformEraseBackground(Self, Canvas.Handle);

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

    { (rb) No longer necessary because of the WM_PRINTCLIENT fix }
//    { (rb) Hack: Force font&brush refresh,
//      - themes seem to delete the font, thus font.handle etc is not valid anymore.
//      - if nothing changed since the last paint cycle, then Canvas.Font
//        equals Self.Font/Self.HotTrackFont, ie Canvas doesn't refresh the
//        font handles due to the assign.
//      - Thus we have to force the font to drop the old handle, don't know other
//        way than calling Changed.
//      (see also remark at TCustomActionControl.Paint)
//    }
//    TFontAccessProtected(Canvas.Font).Changed;
//    TFontAccessProtected(Canvas.Brush).Changed;

    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;