jvqarrowbutton.pas

East make Tray Icon in delphi

    Spacing, FState, Flat);

  { calculate were to put arrow part }
  PaintRect := Rect(Width - ArrowWidth, 0, Width, Height); 
  Push := FArrowClick or (PressBoth and (FState in [bsDown, bsExclusive]));
  if Push then
  begin
    Offset.X := 1;
    Offset.Y := 1;
  end
  else
  begin
    Offset.X := 0;
    Offset.Y := 0;
  end;

  if not Flat then
  begin
    DrawFlags := DFCS_BUTTONPUSH; // or DFCS_ADJUSTRECT;
    if Push then
      DrawFlags := DrawFlags or DFCS_PUSHED;
    if IsMouseOver(Self) then
      DrawFlags := DrawFlags or DFCS_HOT;
    DrawThemedFrameControl(Self, Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
  end
  else
  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);  
      if FMouseInControl then
        MouseLeave(Self)
      else
        MouseEnter(Self); 
    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; 
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);  
    repeat
      Application.ProcessMessages;
    until IsWindowVisible(DropDown.Handle) = False; 
  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;



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;
    {$IFDEF VCL}
    Parent.Broadcast(Msg);
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    BroadcastMsg(Parent, Msg);
    {$ENDIF VisualCLX}
  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; 
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; 
          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;



procedure TJvArrowButton.MouseEnter(Control: TControl);

begin
  inherited MouseEnter(Control);
  if Flat and not FMouseInControl and Enabled then
  begin
    FMouseInControl := True;
    Repaint;
  end; 
end;

procedure TJvArrowButton.MouseLeave(Control: TControl);

begin
  inherited MouseLeave(Control);
  if Flat and FMouseInControl and Enabled then
  begin
    FMouseInControl := False;
    Invalidate;
  end; 
end;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvQArrowButton.pas,v $';
    Revision: '$Revision: 1.23 $';
    Date: '$Date: 2005/02/06 14:06:00 $';
    LogPath: 'JVCL\run'
  );

initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.