jvcaptionbutton.pas

East make Tray Icon in delphi

    constructor Create; virtual;
    destructor Destroy; override;

    procedure AddClient;
    procedure RemoveClient;

    procedure Update;
    procedure DrawSimple(ACanvas: TCanvas; State: Integer; const DrawRect: TRect);
    function Draw(ACanvas: TCanvas; State: Integer; const DrawRect: TRect): Boolean;
    property IsThemed: Boolean read FIsThemed;
  end;

var
  GGlobalXPData: TGlobalXPData;

//=== Local procedures =======================================================

function GlobalXPData: TGlobalXPData;
begin
  if not Assigned(GGlobalXPData) then
    GGlobalXPData := TGlobalXPData.Create;

  Result := GGlobalXPData;
end;

function TranslateBitmapFileName(const S: string): string;
var
  I: Integer;
begin
  Result := S;
  for I := 1 to Length(S) do
    case S[I] of
      'A'..'Z', '0'..'9':
        {do nothing};
      'a'..'z':
        Result[I] := UpCase(S[I]);
    else
      Result[I] := '_';
    end;
end;

procedure DupBits(Src, Dst: HBitmap; Size: TPoint);
var
  MemDC: HDC;
  DesktopDC: HDC;
  OldBitmap: HBitmap;
begin
  OldBitmap := 0;
  DesktopDC := GetDC(GetDesktopWindow);
  MemDC := CreateCompatibleDC(DesktopDC);
  try
    OldBitmap := SelectObject(MemDC, Src);
    BitBlt(Dst, 0, 0, Size.X, Size.Y, MemDC, 0, 0, SRCCOPY);
  finally
    SelectObject(MemDC, OldBitmap);
    ReleaseDC(GetDesktopWindow, DesktopDC);
    DeleteDC(MemDC);
  end;
end;

function GetHasAlphaChannel(Data: PChar; Count: Integer): Boolean;
begin
  Result := False;

  while Count > 0 do
  begin
    Result := PRGBQuad(Data).rgbReserved <> 0;
    if Result then
      Exit;
    Inc(Data, 4);
    Dec(Count);
  end;
end;

procedure PreMultiplyAlphaChannel(Data: PChar; Count: Integer);
begin
  while Count > 0 do
  begin
    with PRGBQuad(Data)^ do
    begin
      rgbBlue := (rgbBlue * rgbReserved + 128) div 255;
      rgbGreen := (rgbGreen * rgbReserved + 128) div 255;
      rgbRed := (rgbRed * rgbReserved + 128) div 255;
    end;
    Inc(Data, 4);
    Dec(Count);
  end;
end;

{$ENDIF JVCLThemesEnabled}

procedure UnloadMsimg32Dll;
begin
  _TransparentBlt := nil;
  _AlphaBlend := nil;
  if GMsimg32Handle > 0 then
    FreeLibrary(GMsimg32Handle);
  GMsimg32Handle := 0;
end;

procedure LoadMsimg32Dll;
begin
  GTriedLoadMsimg32Dll := True;
  GMsimg32Handle := Windows.LoadLibrary(Msimg32DLLName);
  if GMsimg32Handle > 0 then
  begin
    _TransparentBlt := GetProcAddress(GMsimg32Handle, TransparentBltName);
    _AlphaBlend := GetProcAddress(GMsimg32Handle, AlphaBlendName);
  end;
end;

{$IFDEF JVCLThemesEnabled}

function TransparentBltStretch(DestDC: HDC; const DestRect: TRect;
  SourceDC: HDC; const SourceRect: TRect; const SizingMargins: TMargins;
  const TransparentColor: TColor): Boolean;
var
  ESourceWidth, ESourceHeight: Integer;
  EDestWidth, EDestHeight: Integer;
  LastOriginSource: TPoint;
  LastOriginDest: TPoint;
begin
  {                Source                           Dest

               |--------------|             |--------------------|
               | A |   B  | C |             | A |      B     | C |
               |-- |------|---|             |-- |------------|---|
               |   |      |   |             |   |            |   |
               | D |   E  | F |             |   |            |   |
               |   |      |   |     =>      | D |      E     | F |
               |---|------|---|             |   |            |   |
               | G |   H  | I |             |   |            |   |
               |--------------|             |--------------------|
                                            | G |      H     | I |
                                            |-- |------------|---|
  }
  ESourceWidth := SourceRect.Right - SourceRect.Left - SizingMargins.cxLeftWidth - SizingMargins.cxRightWidth;
  ESourceHeight := SourceRect.Bottom - SourceRect.Top - SizingMargins.cyTopHeight - SizingMargins.cyBottomHeight;
  EDestWidth := DestRect.Right - DestRect.Left - SizingMargins.cxLeftWidth - SizingMargins.cxRightWidth;
  EDestHeight := DestRect.Bottom - DestRect.Top - SizingMargins.cyTopHeight - SizingMargins.cyBottomHeight;

  GetWindowOrgEx(SourceDC, LastOriginSource);
  SetWindowOrgEx(SourceDC, LastOriginSource.X - SourceRect.Left, LastOriginSource.Y - SourceRect.Top, nil);
  GetWindowOrgEx(DestDC, LastOriginDest);
  SetWindowOrgEx(DestDC, LastOriginDest.X - DestRect.Left, LastOriginDest.Y - DestRect.Top, nil);

  Result :=
    { A }
  TransparentBlt(
    DestDC,
    0, 0, SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight,
    SourceDC,
    0, 0, SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight,
    TransparentColor
    ) and

  { B }
  TransparentBlt(
    DestDC,
    SizingMargins.cxLeftWidth, 0, EDestWidth, SizingMargins.cyTopHeight,
    SourceDC,
    SizingMargins.cxLeftWidth, 0, ESourceWidth, SizingMargins.cyTopHeight,
    TransparentColor
    ) and

  { C }
  TransparentBlt(
    DestDC,
    EDestWidth + SizingMargins.cxLeftWidth, 0, SizingMargins.cxRightWidth, SizingMargins.cyTopHeight,
    SourceDC,
    ESourceWidth + SizingMargins.cxLeftWidth, 0, SizingMargins.cxRightWidth, SizingMargins.cyTopHeight,
    TransparentColor
    ) and

  { D }
  TransparentBlt(
    DestDC,
    0, SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, EDestHeight,
    SourceDC,
    0, SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, ESourceHeight,
    TransparentColor
    ) and

  { E }
  TransparentBlt(
    DestDC,
    SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, EDestWidth, EDestHeight,
    SourceDC,
    SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, ESourceWidth, ESourceHeight,
    TransparentColor
    ) and

  { F }
  TransparentBlt(
    DestDC,
    EDestWidth + SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, SizingMargins.cxRightWidth, EDestHeight,
    SourceDC,
    ESourceWidth + SizingMargins.cxLeftWidth, SizingMargins.cyTopHeight, SizingMargins.cxRightWidth, ESourceHeight,
    TransparentColor
    ) and

  { G }
  TransparentBlt(
    DestDC,
    0, EDestHeight + SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, SizingMargins.cyBottomHeight,
    SourceDC,
    0, ESourceHeight + SizingMargins.cyTopHeight, SizingMargins.cxLeftWidth, SizingMargins.cyBottomHeight,
    TransparentColor
    ) and

  { H }
  TransparentBlt(
    DestDC,
    SizingMargins.cxLeftWidth, EDestHeight + SizingMargins.cyTopHeight, EDestWidth, SizingMargins.cyBottomHeight,
    SourceDC,
    SizingMargins.cxLeftWidth, ESourceHeight + SizingMargins.cyTopHeight, ESourceWidth, SizingMargins.cyBottomHeight,
    TransparentColor
    ) and

  { I }
  TransparentBlt(
    DestDC,
    EDestWidth + SizingMargins.cxLeftWidth, EDestHeight + SizingMargins.cyTopHeight,
    SizingMargins.cxRightWidth, SizingMargins.cyBottomHeight,
    SourceDC,
    ESourceWidth + SizingMargins.cxLeftWidth, ESourceHeight + SizingMargins.cyTopHeight,
    SizingMargins.cxRightWidth, SizingMargins.cyBottomHeight,
    TransparentColor
    );

  SetWindowOrgEx(SourceDC, LastOriginSource.X, LastOriginSource.Y, nil);
  SetWindowOrgEx(DestDC, LastOriginDest.X, LastOriginDest.Y, nil);
end;

function GetXPCaptionButtonBitmap(ABitmap: TBitmapAdapter; out BitmapCount: Integer): Boolean;
var
  Handle: THandle;
  ThemeFileNameW, BitmapFileNameW: array [0..MAX_PATH] of WideChar;
  OldError: Longint;
  Details: TThemedElementDetails;
  Margins: TMargins;
begin
  ThemeFileNameW[MAX_PATH] := #0;
  BitmapFileNameW[MAX_PATH] := #0;

  Result := UxTheme.GetCurrentThemeName(ThemeFileNameW, MAX_PATH, nil, 0, nil, 0) = S_OK;
  if not Result then
    Exit;

  Details := ThemeServices.GetElementDetails(twMinButtonNormal);
  with Details do
    Result := GetThemeFilename(ThemeServices.Theme[Element], Part, State,
      TMT_IMAGEFILE, BitmapFileNameW, MAX_PATH) = S_OK;
  if not Result then
    Exit;

  with Details do
    Result := GetThemeInt(ThemeServices.Theme[Element], Part, State,
      TMT_IMAGECOUNT, BitmapCount) = S_OK;
  if not Result then
    Exit;

  Result := BitmapCount > 0;
  if not Result then
    Exit;

  with Details do
    if GetThemeMargins(ThemeServices.Theme[Element], 0, Part, State,
      TMT_SIZINGMARGINS, nil, Margins) <> S_OK then
      FillChar(Margins, SizeOf(Margins), 0);
  ABitmap.Margins := Margins;

  OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX or SEM_FAILCRITICALERRORS);
  try
    Handle := LoadLibraryW(ThemeFileNameW);
    if Handle > 0 then
    try
      ABitmap.LoadFromResourceName(Handle, TranslateBitmapFileName(BitmapFileNameW));
      { (rb) can't determine actual transparent color? }
      ABitmap.TransparentColor := clFuchsia;

      Result := (ABitmap.Width > 0) and (ABitmap.Height > 0);
    finally
      FreeLibrary(Handle);
    end;
  finally
    SetErrorMode(OldError);
  end;
end;

{$ENDIF JVCLThemesEnabled}

//=== Global procedures ======================================================

function AlphaBlend;
begin
  if not GTriedLoadMsimg32Dll then
    LoadMsimg32Dll;
  Result := Assigned(_AlphaBlend);
  if Result then
    asm
      mov esp, ebp
      pop ebp
      jmp [_AlphaBlend]
    end;
end;

function TransparentBlt;
begin
  if not GTriedLoadMsimg32Dll then
    LoadMsimg32Dll;
  Result := Assigned(_TransparentBlt);
  if Result then
    asm
      mov esp, ebp
      pop ebp
      jmp [_TransparentBlt]
    end;
end;

{$IFDEF JVCLThemesEnabled}

//=== { TAlphaBitmap } =======================================================

destructor TAlphaBitmap.Destroy;
begin
  FreeHandle;
  inherited Destroy;
end;

function TAlphaBitmap.CreateDIB(ADC: HDC; AWidth, AHeight: Integer): HBitmap;
begin
  with FBitmapInfo.bmiHeader do
  begin
    biSize := SizeOf(FBitmapInfo.bmiHeader);
    biWidth := AWidth;
    biHeight := AHeight;
    biPlanes := 1;
    biBitCount := 32;
    biCompression := BI_RGB;
    biSizeImage := AWidth * AHeight * 4;
  end;
  // Create the DIB
  Result := CreateDIBSection(ADC, FBitmapInfo, DIB_RGB_COLORS, FBitsMem, 0, 0);
end;

procedure TAlphaBitmap.CreateHandle(AWidth, AHeight: Integer);
var
  H: HBitmap;
begin
  FreeHandle;

  H := CreateCompatibleDC(HDC_DESKTOP);
  FDIBHandle := CreateDIB(H, AWidth, AHeight);
  if FDIBHandle <> 0 then
    FOldBitmap := SelectObject(H, FDIBHandle)
  else
    FOldBitmap := 0;
  FHandle := H;
end;

procedure TAlphaBitmap.Duplicate(Src: HBitmap);
var
  Bitmap: Windows.TBitmap;
begin
  GetObject(Src, SizeOf(Bitmap), @Bitmap);
  CreateHandle(Bitmap.bmWidth, Bitmap.bmHeight);

  DupBits(Src, FHandle, Point(Bitmap.bmWidth, Bitmap.bmHeight));
end;

procedure TAlphaBitmap.FreeHandle;
begin
  if FHandle <> 0 then
  begin
    if FDIBHandle <> 0 then
    begin
      if FOldBitmap <> 0 then
        SelectObject(FHandle, FOldBitmap);
      DeleteObject(FDIBHandle);
    end;
    DeleteDC(FHandle);
  end;
end;

function TAlphaBitmap.GetHeight: Integer;
begin
  Result := FBitmapInfo.bmiHeader.biHeight;
end;

function TAlphaBitmap.GetWidth: Integer;
begin
  Result := FBitmapInfo.bmiHeader.biWidth;
end;

procedure TAlphaBitmap.InitAlpha;
var
  Count: Integer;
begin
  Count := Width * Height;
  if BitCount < 32 then
    FHasAlphaChannel := False
  else
  begin
    FHasAlphaChannel := GetHasAlphaChannel(Data, Count);

    if HasAlphaChannel then
      PreMultiplyAlphaChannel(Data, Count);
  end;
end;

procedure TAlphaBitmap.LoadFromResourceID(Instance: THandle; ResID: Integer);
var
  Stream: TCustomMemoryStream;
  BitmapInfoHeader: TBitmapInfoHeader;
  BitmapHandle: HBitmap;
begin
  Stream := TResourceStream.CreateFromID(Instance, ResID, RT_BITMAP);
  try
    Stream.Read(BitmapInfoHeader, SizeOf(TBitmapInfoHeader));
    FBitCount := BitmapInfoHeader.biBitCount;
  finally
    Stream.Free;
  end;

  if FBitCount = 32 then