jvarrowbutton.pas

East make Tray Icon in delphi

  if FMouseInControl and Enabled or (csDesigning in ComponentState) then
    DrawEdge(Canvas.Handle, PaintRect, DownStyles[Push],
      FillStyles[Flat] or BF_RECT);
  { find middle pixel }
  with PaintRect do
  begin
    DivX := Right - Left;
    DivX := DivX div 2;
    DivY := Bottom - Top;
    DivY := DivY div 2;
    Bottom := Bottom - (DivY + DivX div 2) + 1;
    Top := Top + (DivY + DivX div 2) + 1;
    Left := Left + (DivX div 2);
    Right := (Right - DivX div 2);
  end;

  if not Flat then
    Dec(Offset.X);
  OffsetRect(PaintRect, Offset.X, Offset.Y);

  if Enabled then
    Canvas.Pen.Color := clBlack
  else
    Canvas.Pen.Color := clBtnShadow;

  { Draw arrow }
  while PaintRect.Left < PaintRect.Right + 1 do
  begin
    DrawLine(Canvas, PaintRect.Left, PaintRect.Bottom, PaintRect.Right, PaintRect.Bottom);
    InflateRect(PaintRect, -1, 1);
  end;
end;

procedure TJvArrowButton.UpdateTracking;
var
  P: TPoint;
begin
  if Flat then
    if Enabled then
    begin
      GetCursorPos(P);
      FMouseInControl := not (FindDragTarget(P, True) = Self);
      {$IFDEF VCL}
      if FMouseInControl then
        Perform(CM_MOUSELEAVE, 0, 0)
      else
        Perform(CM_MOUSEENTER, 0, 0);
      {$ENDIF VCL}
      {$IFDEF VisualCLX}
      if FMouseInControl then
        MouseLeave(Self)
      else
        MouseEnter(Self);
      {$ENDIF VisualCLX}
    end;
end;

procedure TJvArrowButton.Loaded;
var
  State: TButtonState;
begin
  inherited Loaded;
  if Enabled then
    State := bsUp
  else
    State := bsDisabled;
  TButtonGlyph(FGlyph).CreateButtonGlyph(State);
end;

procedure TJvArrowButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  Pnt: TPoint;
  {$IFDEF VCL}
  Msg: TMsg;
  {$ENDIF VCL}
begin
  inherited MouseDown(Button, Shift, X, Y);
  if not Enabled then
    Exit;
  FArrowClick := (X >= Width - ArrowWidth) and (X <= Width) and (Y >= 0) and (Y <= Height);

  if Button = mbLeft then
  begin
    if not Down then
      FState := bsDown
    else
      FState := bsExclusive;
    Repaint; // Invalidate;
  end;

  if Assigned(FDropDown) and FArrowClick then
  begin
    Pnt := ClientToScreen(Point(0, Height));
    DropDown.Popup(Pnt.X, Pnt.Y);
    {$IFDEF VCL}
    while PeekMessage(Msg, HWND_DESKTOP, WM_MOUSEFIRST, WM_MOUSELAST, PM_REMOVE) do
      {nothing};
    if GetCapture <> 0 then
      SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    repeat
      Application.ProcessMessages;
    until IsWindowVisible(DropDown.Handle) = False;
    {$ENDIF VisualCLX}
  end;

  if FArrowClick then
    if Assigned(FOnDrop) then
      FOnDrop(Self);
  FArrowClick := False;
  Repaint;
end;

procedure TJvArrowButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  DoClick: Boolean;
begin
  inherited MouseUp(Button, Shift, X, Y);

  if not Enabled then
  begin
    FState := bsUp;
    Repaint;
  end;

  DoClick := (X >= 0) and (X <= Width - ArrowWidth) and (Y >= 0) and (Y <= Height);

  if GroupIndex = 0 then
  begin
    { Redraw face in case mouse is captured }
    FState := bsUp;
    FMouseInControl := False;
    if DoClick and not (FState in [bsExclusive, bsDown]) then
      Invalidate;
  end
  else
  if DoClick then
  begin
    SetDown(not Down);
    if Down then
      Repaint;
  end
  else
  begin
    if Down then
      FState := bsExclusive;
    Repaint;
  end;
  if DoClick then
    Click;
  UpdateTracking;
  Repaint;
end;

{$IFDEF VCL}
function TJvArrowButton.GetPalette: HPALETTE;
begin
  Result := Glyph.Palette;
end;
{$ENDIF VCL}

function TJvArrowButton.GetGlyph: TBitmap;
begin
  Result := TButtonGlyph(FGlyph).Glyph;
end;

procedure TJvArrowButton.SetGlyph(Value: TBitmap);
begin
  TButtonGlyph(FGlyph).Glyph := Value;
  Invalidate;
end;

function TJvArrowButton.GetNumGlyphs: TNumGlyphs;
begin
  Result := TButtonGlyph(FGlyph).NumGlyphs;
end;

procedure TJvArrowButton.SetNumGlyphs(Value: TNumGlyphs);
begin
  if Value < 0 then
    Value := 1
  else
  if Value > 4 then
    Value := 4;
  if Value <> TButtonGlyph(FGlyph).NumGlyphs then
  begin
    TButtonGlyph(FGlyph).NumGlyphs := Value;
    Invalidate;
  end;
end;

procedure TJvArrowButton.GlyphChanged(Sender: TObject);
begin
  Invalidate;
end;

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

procedure TJvArrowButton.SetDown(Value: Boolean);
begin
  if GroupIndex = 0 then
    Value := False;
  if Value <> FDown then
  begin
    if FDown and (not AllowAllUp) then
      Exit;
    FDown := Value;
    if Value then
    begin
      if FState = bsUp then
        Invalidate;
      FState := bsExclusive
    end
    else
    begin
      FState := bsUp;
      Repaint;
    end;
    if Value then
      UpdateExclusive;
  end;
end;

procedure TJvArrowButton.SetFlat(Value: Boolean);
begin
  if Value <> FFlat then
  begin
    FFlat := Value;
    if Value then
      ControlStyle := ControlStyle - [csOpaque]
    else
      ControlStyle := ControlStyle + [csOpaque];
    Invalidate;
  end;
end;

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

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

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

procedure TJvArrowButton.SetArrowWidth(Value: Integer);
begin
  if FArrowWidth <> Value then
  begin
    FArrowWidth := Value;
    Repaint;
  end;
end;

procedure TJvArrowButton.SetFillFont(Value: TFont);
begin
  FFillFont.Assign(Value);
  Repaint;
end;

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

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

procedure TJvArrowButton.EnabledChanged;
const
  NewState: array [Boolean] of TButtonState = (bsDisabled, bsUp);
begin
  inherited EnabledChanged;
  TButtonGlyph(FGlyph).CreateButtonGlyph(NewState[Enabled]);
  UpdateTracking;
  Repaint;
end;

procedure TJvArrowButton.CMButtonPressed(var Msg: TCMButtonPressed);
var
  Sender: TJvArrowButton;
  {$IFDEF JVCLThemesEnabled}
  R: TRect;
  {$ENDIF JVCLThemesEnabled}
begin
  if Msg.Index = GroupIndex then
  begin
    Sender := TJvArrowButton(Msg.Control);
    if Sender <> Self then
    begin
      if Sender.Down and Down then
      begin
        FDown := False;
        FState := bsUp;
        {$IFDEF JVCLThemesEnabled}
        if ThemeServices.ThemesEnabled and Enabled and not Flat then
        begin
          R := BoundsRect;
          InvalidateRect(Parent.Handle, @R, True);
        end
        else
        {$ENDIF JVCLThemesEnabled}
          Invalidate;
      end;
      FAllowAllUp := Sender.AllowAllUp;
    end;
  end;
end;

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

procedure TJvArrowButton.FontChanged;
begin
  inherited FontChanged;
  Invalidate;
end;

procedure TJvArrowButton.TextChanged;
begin
  inherited TextChanged;
  Invalidate;
end;

{$IFDEF VCL}

procedure TJvArrowButton.WMLButtonDblClk(var Msg: TWMLButtonDown);
begin
  inherited;
  if Down then
    DblClick;
end;

procedure TJvArrowButton.CMSysColorChange(var Msg: TMessage);
begin
  with TButtonGlyph(FGlyph) do
  begin
    Invalidate;
    CreateButtonGlyph(FState);
  end;
end;

{$ENDIF VCL}

procedure TJvArrowButton.MouseEnter(Control: TControl);
{$IFDEF JVCLThemesEnabled}
var
  R: TRect;
{$ENDIF JVCLThemesEnabled}
begin
  inherited MouseEnter(Control);
  if Flat and not FMouseInControl and Enabled then
  begin
    FMouseInControl := True;
    Repaint;
  end;
  {$IFDEF JVCLThemesEnabled}
  if ThemeServices.ThemesEnabled and Enabled and not Flat then
  begin
    R := BoundsRect;
    InvalidateRect(Parent.Handle, @R, True);
  end;
  {$ENDIF JVCLThemesEnabled}
end;

procedure TJvArrowButton.MouseLeave(Control: TControl);
{$IFDEF JVCLThemesEnabled}
var
  R: TRect;
{$ENDIF JVCLThemesEnabled}
begin
  inherited MouseLeave(Control);
  if Flat and FMouseInControl and Enabled then
  begin
    FMouseInControl := False;
    Invalidate;
  end;
  {$IFDEF JVCLThemesEnabled}
  if ThemeServices.ThemesEnabled and Enabled and not Flat then
  begin
    R := BoundsRect;
    InvalidateRect(Parent.Handle, @R, True);
  end;
  {$ENDIF JVCLThemesEnabled}
end;

{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.