jvspeedbutton.pas

East make Tray Icon in delphi

    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 }
      LState := FState;

    PaintImage(Canvas, PaintRect, Offset, LState,
      FMarkDropDown and Assigned(FDropDownMenu));
  end
  else
  {$ENDIF JVCLThemesEnabled}
  begin
    with Canvas do
    begin
      if FTransparent then
        CopyParentImage(Self, Canvas)
      else
      begin
        Brush.Color := Self.Color;
        Brush.Style := bsSolid;
        FillRect(PaintRect);
      end;
      if (LState <> 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 (LState = 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 }
      LState := 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
            Canvas.Brush.Bitmap := CreateTwoColorsBrushPattern(HotTrackOptions.Color, clWindow)
          else
          begin
            Canvas.Brush.Color := HotTrackOptions.Color;
            Canvas.Brush.Style := bsSolid;
          end;
          Canvas.Pen.Color := HotTrackOptions.FrameColor;
          Canvas.Rectangle(0, 0, Width, Height);
          if Down then
            Canvas.Brush.Bitmap := nil; // release bitmap
        end;
      {Insert End}
    end else
      Canvas.Font := Self.Font;
    PaintImage(Canvas, PaintRect, Offset, LState,
      FMarkDropDown and Assigned(FDropDownMenu));
  end;
end;

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

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

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

procedure TJvCustomSpeedButton.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 TJvCustomSpeedButton.SetDropdownMenu(Value: TPopupMenu);
begin
  FDropDownMenu := Value;
  if Value <> nil then
    Value.FreeNotification(Self);
  if FMarkDropDown then
    Invalidate;
end;

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

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

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

procedure TJvCustomSpeedButton.SetHotTrackFont(const Value: TFont);
begin
  FHotTrackFont.Assign(Value);
end;

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

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

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

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

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

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

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

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

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

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

procedure TJvCustomSpeedButton.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 TJvCustomSpeedButton.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 TJvCustomSpeedButton.WMLButtonDblClk(var Msg: TWMLButtonDown);
begin
  if not FMenuTracking then
  begin
    inherited;
    if FDown then
      DblClick;
  end;
end;
{$ENDIF VCL}

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

{$IFDEF VCL}
procedure TJvCustomSpeedButton.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);
      Msg.DC := MemDC;

      inherited;

      Msg.DC := DC;
      RestoreDC(Msg.DC, Index);
      BitBlt(Msg.DC, 0, 0, Width, Height, MemDC, 0, 0, SRCCOPY);
    finally
      SelectObject(MemDC, SaveBitmap);
      DeleteDC(MemDC);
      DeleteObject(MemBitmap);
    end;
  end;
end;

procedure TJvCustomSpeedButton.WMRButtonDown(var Msg: TWMRButtonDown);
begin
  inherited;
  UpdateTracking;
end;

procedure TJvCustomSpeedButton.WMRButtonUp(var Msg: TWMRButtonUp);
begin
  inherited;
  UpdateTracking;
end;

{$ENDIF VCL}

{Inserted by (ag) 2004-09-04}
procedure TJvCustomSpeedButton.SetHotTrackOptions(Value: TJvSpeedButtonHotTrackOptions);
begin
  FHotTrackOptions.Assign(Value);
end;
{Insert End}

//=== { TJvGlyphCache } ======================================================

constructor TJvGlyphCache.Create;
begin
  inherited Create;
  FGlyphLists := TList.Create;
end;

destructor TJvGlyphCache.Destroy;
begin
  FGlyphLists.Free;
  inherited Destroy;
end;

function TJvGlyphCache.Empty: Boolean;
begin
  Result := FGlyphLists.Count = 0;
end;

function TJvGlyphCache.GetList(AWidth, AHeight: Integer): TJvGlyphList;
var
  I: Integer;
begin
  for I := FGlyphLists.Count - 1 downto 0 do
  begin
    Result := FGlyphLists[I];
    with Result do
      if (AWidth = Width) and (AHeight = Height) then
        Exit;
  end;
  Result := TJvGlyphList.CreateSize(AWidth, AHeight);
  FGlyphLists.Add(Result);
end;

procedure TJvGlyphCache.ReturnList(List: TJvGlyphList);
begin
  if List = nil then
    Exit;
  if List.Count = 0 then
  begin
    FGlyphLists.Remove(List);
    List.Free;
  end;
end;

//=== { TJvGlyphList } =======================================================

function TJvGlyphList.Add(Image, Mask: TBitmap): Integer;