jvcaptionbutton.pas

East make Tray Icon in delphi

  begin
    BitmapHandle := LoadImage(Instance, PChar(ResID), IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION);
    if BitmapHandle = 0 then
      Exit;

    Duplicate(BitmapHandle);
    DeleteObject(BitmapHandle);

    InitAlpha;
  end;
end;

procedure TAlphaBitmap.LoadFromResourceName(Instance: THandle; const ResName: string);
var
  Stream: TCustomMemoryStream;
  BitmapInfoHeader: TBitmapInfoHeader;
  BitmapHandle: HBitmap;
begin
  Stream := TResourceStream.Create(Instance, ResName, RT_BITMAP);
  try
    Stream.Read(BitmapInfoHeader, SizeOf(TBitmapInfoHeader));
    FBitCount := BitmapInfoHeader.biBitCount;
  finally
    Stream.Free;
  end;

  if FBitCount = 32 then
  begin
    BitmapHandle := LoadImage(Instance, PChar(ResName), IMAGE_BITMAP, 0, 0, LR_CREATEDIBSECTION);
    if BitmapHandle = 0 then
      Exit;

    Duplicate(BitmapHandle);
    DeleteObject(BitmapHandle);

    InitAlpha;
  end;
end;

//=== { TBitmapAdapter } =====================================================

constructor TBitmapAdapter.Create;
begin
  inherited Create;
  FTransparentColor := clFuchsia;
end;

destructor TBitmapAdapter.Destroy;
begin
  FBitmap.Free;
  inherited Destroy;
end;

procedure TBitmapAdapter.Clear;
begin
  FreeAndNil(FBitmap);
end;

function TBitmapAdapter.Draw(ACanvas: TCanvas; const Rect: TRect;
  AMargins: PMargins): Boolean;
begin
  if (Rect.Right - Rect.Left = Width) and (Rect.Bottom - Rect.Top = Height) then
    Result := DrawFixedPart(ACanvas, Rect, 0, 0)
  else
  begin
    if AMargins = nil then
      AMargins := @FMargins;

    if FBitmap is TAlphaBitmap then
      with TAlphaBitmap(FBitmap) do
        Result := TransparentBltStretch(ACanvas.Handle, Rect, Handle,
          Bounds(0, 0, Width, Height), AMargins^, FTransparentColor)
    else
    if FBitmap is TBitmap then
      with TBitmap(FBitmap) do
        Result := TransparentBltStretch(ACanvas.Handle, Rect, Canvas.Handle,
          Bounds(0, 0, Width, Height), AMargins^, FTransparentColor)
    else
      Result := False;
  end;
end;

function TBitmapAdapter.DrawFixed(ACanvas: TCanvas; const X, Y: Integer): Boolean;
begin
  Result := DrawFixedPart(ACanvas, Bounds(X, Y, Width, Height), 0, 0);
end;

function TBitmapAdapter.DrawFixedPart(ACanvas: TCanvas;
  const DestRect: TRect; const SrcX, SrcY: Integer): Boolean;
var
  BlendFunction: TBlendFunction;
  W, H: Integer;
begin
  W := DestRect.Right - DestRect.Left;
  H := DestRect.Bottom - DestRect.Top;

  if FBitmap is TAlphaBitmap then
  begin
    with TAlphaBitmap(FBitmap) do
    begin
      BlendFunction.BlendOp := AC_SRC_OVER;
      BlendFunction.BlendFlags := 0;
      BlendFunction.SourceConstantAlpha := $FF;
      BlendFunction.AlphaFormat := AC_SRC_ALPHA;

      Result := AlphaBlend(ACanvas.Handle, DestRect.Left, DestRect.Top, W, H,
        Handle, SrcX, SrcY, W, H, BlendFunction);
    end;
  end
  else
  if FBitmap is TBitmap then
    with TBitmap(FBitmap) do
      Result := TransparentBlt(ACanvas.Handle, DestRect.Left, DestRect.Top, W, H,
        Canvas.Handle, SrcX, SrcY, W, H, Self.TransparentColor)
  else
    Result := False;
end;

function TBitmapAdapter.DrawPart(ACanvas: TCanvas; const SrcRect,
  DestRect: TRect; AMargins: PMargins): Boolean;
begin
  // Same width/height?
  if (SrcRect.Right - SrcRect.Left = DestRect.Right - DestRect.Left) and
    (SrcRect.Bottom - SrcRect.Top = DestRect.Bottom - DestRect.Top) then
    Result := DrawFixedPart(ACanvas, DestRect, SrcRect.Left, SrcRect.Top)
  else
  begin
    if AMargins = nil then
      AMargins := @FMargins;

    if FBitmap is TAlphaBitmap then
      with TAlphaBitmap(FBitmap) do
        Result := TransparentBltStretch(ACanvas.Handle, DestRect, Handle, SrcRect,
          AMargins^, Self.TransparentColor)
    else
    if FBitmap is TBitmap then
      with TBitmap(FBitmap) do
        Result := TransparentBltStretch(ACanvas.Handle, DestRect, Canvas.Handle, SrcRect,
          AMargins^, Self.TransparentColor)
    else
      Result := False;
  end;
end;

function TBitmapAdapter.GetHeight: Integer;
begin
  if FBitmap is TAlphaBitmap then
    Result := TAlphaBitmap(FBitmap).Height
  else
  if FBitmap is TBitmap then
    Result := TBitmap(FBitmap).Height
  else
    Result := 0;
end;

function TBitmapAdapter.GetIsValid: Boolean;
begin
  Result := Assigned(FBitmap);
end;

function TBitmapAdapter.GetWidth: Integer;
begin
  if FBitmap is TAlphaBitmap then
    Result := TAlphaBitmap(FBitmap).Width
  else
  if FBitmap is TBitmap then
    Result := TBitmap(FBitmap).Width
  else
    Result := 0;
end;

procedure TBitmapAdapter.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
  AlphaBitmap: TAlphaBitmap;
begin
  Clear;

  AlphaBitmap := TAlphaBitmap.Create;
  try
    AlphaBitmap.LoadFromResourceID(Instance, ResID);
    if AlphaBitmap.BitCount < 32 then
    begin
      FBitmap := TBitmap.Create;
      TBitmap(FBitmap).LoadFromResourceID(Instance, ResID);
    end
    else
    begin
      FBitmap := AlphaBitmap;
      AlphaBitmap := nil;
    end;
  finally
    AlphaBitmap.Free;
  end;
end;

procedure TBitmapAdapter.LoadFromResourceName(Instance: THandle; const ResName: string);
var
  AlphaBitmap: TAlphaBitmap;
begin
  Clear;

  AlphaBitmap := TAlphaBitmap.Create;
  try
    AlphaBitmap.LoadFromResourceName(Instance, ResName);
    if AlphaBitmap.BitCount < 32 then
    begin
      FBitmap := TBitmap.Create;
      TBitmap(FBitmap).LoadFromResourceName(Instance, ResName);
    end
    else
    begin
      FBitmap := AlphaBitmap;
      AlphaBitmap := nil;
    end;
  finally
    AlphaBitmap.Free;
  end;
end;

//=== { TGlobalXPData } ======================================================

constructor TGlobalXPData.Create;
begin
  inherited Create;
  Update;
end;

destructor TGlobalXPData.Destroy;
begin
  FCaptionButtons.Free;
  inherited Destroy;
end;

procedure TGlobalXPData.AddClient;
begin
  Inc(FClientCount);
end;

function TGlobalXPData.Draw(ACanvas: TCanvas; State: Integer;
  const DrawRect: TRect): Boolean;
var
  SrcRect: TRect;
begin
  Result := FBitmapValid;
  if not Result then
    Exit;

  { State is 1-based }
  if (State >= FCaptionButtonCount) and (State > 4) then
    State := ((State - 1) mod 4) + 1;
  if State > FCaptionButtonCount then
    State := FCaptionButtonCount;

  SrcRect := Bounds(0, FCaptionButtonHeight * (State - 1),
    FCaptionButtons.Width, FCaptionButtonHeight);

  Result := FCaptionButtons.DrawPart(ACanvas, SrcRect, DrawRect, nil);
end;

procedure TGlobalXPData.DrawSimple(ACanvas: TCanvas; State: Integer;
  const DrawRect: TRect);
const
  // Normal, Hot, Pushed, Disabled,
  cCaptionButton: array [0..3] of TThemedWindow =
    (twMinButtonNormal, twMinButtonHot, twMinButtonPushed, twMinButtonDisabled);
  cNormalButton: array [0..3] of TThemedButton =
    (tbPushButtonNormal, tbPushButtonHot, tbPushButtonPressed, tbPushButtonDisabled);
var
  Details: TThemedElementDetails;
  DrawRgn: HRGN;
begin
  { Draw the button in 2 pieces, draw the edge of a caption button, and the
    inner of a normal button, because drawing a normal button looks ugly }

  // State = 1..8 -> State = 0..3
  State := (State - 1) mod 4;

  { 1a. Draw the outer bit as a caption button }
  Details := ThemeServices.GetElementDetails(cCaptionButton[State]);
  ThemeServices.DrawElement(ACanvas.Handle, Details, DrawRect);

  { 1b. Draw the inner bit as a normal button }
  with DrawRect do
    DrawRgn := CreateRectRgn(Left + 1, Top + 1, Right - 1, Bottom - 1);
  try
    Details := ThemeServices.GetElementDetails(cNormalButton[State]);
    SelectClipRgn(ACanvas.Handle, DrawRgn);
    ThemeServices.DrawElement(ACanvas.Handle, Details, DrawRect);
    SelectClipRgn(ACanvas.Handle, 0);
  finally
    DeleteObject(DrawRgn);
  end;
end;

procedure TGlobalXPData.RemoveClient;
begin
  Dec(FClientCount);
  if FClientCount = 0 then
  begin
    if Self = GGlobalXPData then
      GGlobalXPData := nil;
    Self.Free;
  end;
end;

procedure TGlobalXPData.Update;
begin
  FIsThemed := ThemeServices.ThemesAvailable and IsThemeActive and IsAppThemed;
  if not FIsThemed then
    Exit;

  if FCaptionButtons = nil then
    FCaptionButtons := TBitmapAdapter.Create;

  FBitmapValid := GetXPCaptionButtonBitmap(FCaptionButtons, FCaptionButtonCount);
  if FBitmapValid then
    FCaptionButtonHeight := FCaptionButtons.Height div FCaptionButtonCount
  else
    FreeAndNil(FCaptionButtons);
end;

{$ENDIF JVCLThemesEnabled}

//=== { TJvCaptionButton } ===================================================

constructor TJvCaptionButton.Create(AOwner: TComponent);
begin
  if not (AOwner is TCustomForm) then
    raise EJVCLException.CreateRes(@RsEOwnerMustBeTCustomForm);

  inherited Create(AOwner);

  { Defaults }
  FAlignment := taLeftJustify;
  FHeight := 0;
  FLeft := 0;
  FTop := 0;
  FWidth := 0;
  FEnabled := True;
  FImageIndex := -1;
  FLayout := cbImageLeft;
  FMargin := -1;
  FPosition := 0;
  FSpacing := 4;
  FStandard := tsbNone;
  FToggle := False;
  FVisible := True;

  FNeedRecalculate := True;
  FCaption := '';
  FDown := False;
  FToolTipHandle := 0;

  FFont := TFont.Create;
  FBuffer := TBitmap.Create;

  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
  FParentShowHint := True;

  {$IFDEF JVCLThemesEnabled}
  GlobalXPData.AddClient;
  {$ENDIF JVCLThemesEnabled}

  Hook;
end;

destructor TJvCaptionButton.Destroy;
begin
  DestroyToolTip;

  UnHook;
  Redraw(rkTotalCaptionBar);

  FFont.Free;
  FBuffer.Free;

  FreeAndNil(FActionLink);
  FreeAndNil(FImageChangeLink);

  {$IFDEF JVCLThemesEnabled}
  GlobalXPData.RemoveClient;
  {$ENDIF JVCLThemesEnabled}

  inherited Destroy;
end;

procedure TJvCaptionButton.ActionChange(Sender: TObject;
  CheckDefaults: Boolean);
begin
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if not CheckDefaults or not Assigned(Self.Images) then
        Self.Images := ActionList.Images;
      if not CheckDefaults or (Self.Caption = '') then
        Self.Caption := Caption;
      if not CheckDefaults or Self.Enabled then
        Self.Enabled := Enabled;
      if not CheckDefaults or (Self.Hint = '') then
        Self.Hint := Hint;
      if not CheckDefaults or (Self.ImageIndex = -1) then
        Self.ImageIndex := ImageIndex;
      if not CheckDefaults or Self.Visible then
        Self.Visible := Visible;
      if not CheckDefaults or not Assigned(Self.OnClick) then
        Self.OnClick := OnExecute;
    end;
end;

procedure TJvCaptionButton.Assign(Source: TPersistent);
begin
  if Source is TJvCaptionButton then
  begin
    Alignment := TJvCaptionButton(Source).Alignment;
    ButtonHeight := TJvCaptionButton(Source).ButtonHeight;
    ButtonLeft := TJvCaptionButton(Source).ButtonLeft;
    ButtonTop := TJvCaptionButton(Source).ButtonTop;
    ButtonWidth := TJvCaptionButton(Source).ButtonWidth;
    Caption := TJvCaptionButton(Source).Caption;
    ShowHint := TJvCaptionButton(Source).ShowHint;
    ParentShowHint := TJvCaptionButton(Source).ParentShowHint;
    Enabled := TJvCaptionButton(Source).Enabled;
    Font := TJvCaptionButton(Source).Font;
    Hint := TJvCaptionButton(Source).Hint;
    ImageIndex := TJvCaptionButton(Source).ImageIndex;