mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-22 13:42:50 +02:00
512 lines
15 KiB
ObjectPascal
512 lines
15 KiB
ObjectPascal
unit Win32Themes;
|
|
|
|
{$mode objfpc}{$H+}
|
|
{$I win32defines.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
// os
|
|
Windows, Win32UxTheme, Win32Proc, Win32Extra,
|
|
// rtl
|
|
Classes, SysUtils,
|
|
// lcl
|
|
Controls, Graphics, Themes, LCLProc, LCLType;
|
|
|
|
type
|
|
|
|
TThemeData = array[TThemedElement] of HTHEME;
|
|
{ TWin32ThemeServices }
|
|
|
|
TWin32ThemeServices = class(TThemeServices)
|
|
private
|
|
FThemeData: TThemeData; // Holds a list of theme data handles.
|
|
protected
|
|
function GetTheme(Element: TThemedElement): HTHEME;
|
|
function InitThemes: Boolean; override;
|
|
procedure UnloadThemeData; override;
|
|
function UseThemes: Boolean; override;
|
|
function ThemedControlsEnabled: Boolean; override;
|
|
|
|
function InternalColorToRGB(Details: TThemedElementDetails; Color: TColor): LongInt; override;
|
|
procedure InternalDrawParentBackground(Window: HWND; Target: HDC; Bounds: PRect); override;
|
|
public
|
|
destructor Destroy; override;
|
|
|
|
function GetDetailSize(Details: TThemedElementDetails): TSize; override;
|
|
function GetStockImage(StockID: LongInt; out Image, Mask: HBitmap): Boolean; override;
|
|
function GetOption(AOption: TThemeOption): Integer; override;
|
|
|
|
procedure DrawElement(DC: HDC; Details: TThemedElementDetails; const R: TRect;
|
|
ClipRect: PRect = nil); override;
|
|
procedure DrawEdge(DC: HDC; Details: TThemedElementDetails; const R: TRect; Edge, Flags: Cardinal;
|
|
AContentRect: PRect = nil); override;
|
|
procedure DrawIcon(DC: HDC; Details: TThemedElementDetails; const R: TRect;
|
|
himl: HIMAGELIST; Index: Integer); override;
|
|
procedure DrawIcon(ACanvas: TPersistent; Details: TThemedElementDetails;
|
|
const P: TPoint; AImageList: TPersistent; Index: Integer); override;
|
|
|
|
procedure DrawText(DC: HDC; Details: TThemedElementDetails;
|
|
const S: String; R: TRect; Flags, Flags2: Cardinal); override;
|
|
procedure DrawText(ACanvas: TPersistent; Details: TThemedElementDetails;
|
|
const S: String; R: TRect; Flags, Flags2: Cardinal); override;
|
|
|
|
procedure DrawTextEx(DC: HDC; Details: TThemedElementDetails;
|
|
const S: String; R: TRect; Flags: Cardinal; Options: PDTTOpts);
|
|
|
|
function ContentRect(DC: HDC; Details: TThemedElementDetails; BoundingRect: TRect): TRect; override;
|
|
function HasTransparentParts(Details: TThemedElementDetails): Boolean; override;
|
|
procedure PaintBorder(Control: TObject; EraseLRCorner: Boolean); override;
|
|
property Theme[Element: TThemedElement]: HTHEME read GetTheme;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
TmSchema;
|
|
|
|
const
|
|
ThemeDataNames: array[TThemedElement] of PWideChar = (
|
|
'button', // teButton
|
|
'clock', // teClock
|
|
'combobox', // teComboBox
|
|
'edit', // teEdit
|
|
'explorerbar', // teExplorerBar
|
|
'header', // teHeader
|
|
'listview', // teListView
|
|
'menu', // teMenu
|
|
'page', // tePage
|
|
'progress', // teProgress
|
|
'rebar', // teRebar
|
|
'scrollbar', // teScrollBar
|
|
'spin', // teSpin
|
|
'startpanel', // teStartPanel
|
|
'status', // teStatus
|
|
'tab', // teTab
|
|
'taskband', // teTaskBand
|
|
'taskbar', // teTaskBar
|
|
'toolbar', // teToolBar
|
|
'tooltip', // teToolTip
|
|
'trackbar', // teTrackBar
|
|
'traynotify', // teTrayNotify
|
|
'treeview', // teTreeview
|
|
'window' // teWindow
|
|
);
|
|
|
|
ThemeDataNamesVista: array[TThemedElement] of PWideChar = (
|
|
'button', // teButton
|
|
'clock', // teClock
|
|
'combobox', // teComboBox
|
|
'edit', // teEdit
|
|
'explorerbar', // teExplorerBar
|
|
'header', // teHeader
|
|
'explorer::listview', // teListView
|
|
'menu', // teMenu
|
|
'page', // tePage
|
|
'progress', // teProgress
|
|
'rebar', // teRebar
|
|
'scrollbar', // teScrollBar
|
|
'spin', // teSpin
|
|
'startpanel', // teStartPanel
|
|
'status', // teStatus
|
|
'tab', // teTab
|
|
'taskband', // teTaskBand
|
|
'taskbar', // teTaskBar
|
|
'toolbar', // teToolBar
|
|
'tooltip', // teToolTip
|
|
'trackbar', // teTrackBar
|
|
'traynotify', // teTrayNotify
|
|
'explorer::treeview', // teTreeview
|
|
'window' // teWindow
|
|
);
|
|
|
|
// standard windows icons (WinUser.h)
|
|
// they are already defined in the rtl, however the
|
|
// const = const defines after this fail with an illegal expression
|
|
IDI_APPLICATION = System.MakeIntResource(32512);
|
|
IDI_HAND = System.MakeIntResource(32513);
|
|
IDI_QUESTION = System.MakeIntResource(32514);
|
|
IDI_EXCLAMATION = System.MakeIntResource(32515);
|
|
IDI_ASTERISK = System.MakeIntResource(32516);
|
|
IDI_WINLOGO = System.MakeIntResource(32517); // XP only
|
|
|
|
IDI_WARNING = IDI_EXCLAMATION;
|
|
IDI_ERROR = IDI_HAND;
|
|
IDI_INFORMATION = IDI_ASTERISK;
|
|
|
|
{ TWin32ThemeServices }
|
|
|
|
procedure TWin32ThemeServices.UnloadThemeData;
|
|
var
|
|
Entry: TThemedElement;
|
|
begin
|
|
for Entry := Low(TThemeData) to High(TThemeData) do
|
|
if FThemeData[Entry] <> 0 then
|
|
begin
|
|
CloseThemeData(FThemeData[Entry]);
|
|
FThemeData[Entry] := 0;
|
|
end;
|
|
end;
|
|
|
|
function TWin32ThemeServices.InitThemes: Boolean;
|
|
begin
|
|
Result := InitThemeLibrary;
|
|
FillChar(FThemeData, SizeOf(FThemeData), 0);
|
|
end;
|
|
|
|
destructor TWin32ThemeServices.Destroy;
|
|
begin
|
|
inherited Destroy;
|
|
FreeThemeLibrary;
|
|
end;
|
|
|
|
function TWin32ThemeServices.GetDetailSize(Details: TThemedElementDetails): TSize;
|
|
var
|
|
R: TRect;
|
|
begin
|
|
// GetThemeInt(Theme[Details.Element], Details.Part, Details.State, TMT_HEIGHT, Result);
|
|
// does not work for some reason
|
|
if ThemesEnabled then
|
|
begin
|
|
if (Details.Element = teToolBar) and (Details.Part = TP_SPLITBUTTONDROPDOWN) then
|
|
Result.cx := 12
|
|
else
|
|
if (Details.Element = teTreeview) and (Details.Part in [TVP_GLYPH, TVP_HOTGLYPH]) then
|
|
begin
|
|
R := Rect(0, 0, 800, 800);
|
|
GetThemePartSize(GetTheme(Details.Element), 0, Details.Part, Details.State, @R, TS_TRUE, Result);
|
|
end
|
|
else
|
|
Result := inherited GetDetailSize(Details);
|
|
end
|
|
else
|
|
Result := inherited GetDetailSize(Details);
|
|
end;
|
|
|
|
function TWin32ThemeServices.GetStockImage(StockID: LongInt; out Image, Mask: HBitmap): Boolean;
|
|
var
|
|
IconHandle: HIcon;
|
|
IconInfo: TIconInfo;
|
|
Bitmap: Windows.TBitmap;
|
|
x, y: Integer;
|
|
LinePtr: PByte;
|
|
Pixel: PRGBAQuad;
|
|
SHIconInfo: TSHSTOCKICONINFO;
|
|
begin
|
|
case StockID of
|
|
idDialogWarning: IconHandle := LoadImage(0, IDI_WARNING, IMAGE_ICON, 0, 0, LR_DEFAULTSIZE or LR_SHARED);
|
|
idDialogError : IconHandle := LoadImage(0, IDI_ERROR, IMAGE_ICON, 0, 0, LR_DEFAULTSIZE or LR_SHARED);
|
|
idDialogInfo : IconHandle := LoadImage(0, IDI_INFORMATION, IMAGE_ICON, 0, 0, LR_DEFAULTSIZE or LR_SHARED);
|
|
idDialogConfirm: IconHandle := LoadImage(0, IDI_QUESTION, IMAGE_ICON, 0, 0, LR_DEFAULTSIZE or LR_SHARED);
|
|
idDialogShield:
|
|
begin
|
|
FillChar(SHIconInfo, SizeOf(SHIconInfo), 0);
|
|
SHIconInfo.cbSize := SizeOf(SHIconInfo);
|
|
if (SHGetStockIconInfo(SIID_SHIELD, SHGFI_ICON or SHGFI_LARGEICON, @SHIconInfo) = S_OK) then
|
|
IconHandle := SHIconInfo.hIcon
|
|
else
|
|
IconHandle := 0;
|
|
end;
|
|
idButtonShield:
|
|
begin
|
|
FillChar(SHIconInfo, SizeOf(SHIconInfo), 0);
|
|
SHIconInfo.cbSize := SizeOf(SHIconInfo);
|
|
if (SHGetStockIconInfo(SIID_SHIELD, SHGFI_ICON or SHGFI_SMALLICON, @SHIconInfo) = S_OK) then
|
|
IconHandle := SHIconInfo.hIcon
|
|
else
|
|
IconHandle := 0;
|
|
end;
|
|
else
|
|
IconHandle := 0;
|
|
end;
|
|
Result := (IconHandle <> 0) and GetIconInfo(IconHandle, @IconInfo);
|
|
if not Result then
|
|
begin
|
|
Result := inherited GetStockImage(StockID, Image, Mask);
|
|
Exit;
|
|
end;
|
|
|
|
Image := IconInfo.hbmColor;
|
|
Mask := IconInfo.hbmMask;
|
|
|
|
if WindowsVersion >= wvXP then Exit; // XP and up return alpha bitmaps
|
|
if GetObject(Image, SizeOf(Bitmap), @Bitmap) = 0 then Exit;
|
|
if Bitmap.bmBitsPixel <> 32 then Exit; // we only need to "fix" 32bpp images
|
|
|
|
Image := CopyImage(IconInfo.hbmColor, IMAGE_BITMAP, 0, 0, LR_COPYDELETEORG or LR_CREATEDIBSECTION);
|
|
if WindowsVersion in [wv95, wv98, wvME]
|
|
then begin
|
|
// 95 or ME aren't tested, so if icons appear invisible remove them
|
|
// only copying is enough
|
|
Exit;
|
|
end;
|
|
|
|
// Others remain ( wvUnknown, wvNT4, wv2000 )
|
|
|
|
if GetObject(Image, SizeOf(Bitmap), @Bitmap) = 0 then Exit; // ???
|
|
if Bitmap.bmBits = nil then Exit; // ?? we requested a dibsection, but didn't get one ??
|
|
|
|
LinePtr := Bitmap.bmBits;
|
|
|
|
for y := Bitmap.bmHeight downto 1 do
|
|
begin
|
|
Pixel := Pointer(LinePtr);
|
|
for x := Bitmap.bmWidth downto 1 do
|
|
begin
|
|
Pixel^.Alpha := 255;
|
|
Inc(Pixel);
|
|
end;
|
|
Inc(LinePtr, Bitmap.bmWidthBytes);
|
|
end;
|
|
end;
|
|
|
|
function TWin32ThemeServices.GetOption(AOption: TThemeOption): Integer;
|
|
begin
|
|
case AOption of
|
|
toShowButtonImages: Result := 0;
|
|
else
|
|
Result := inherited GetOption(AOption);
|
|
end;
|
|
end;
|
|
|
|
function TWin32ThemeServices.UseThemes: Boolean;
|
|
begin
|
|
Result := Win32UxTheme.UseThemes and (GetFileVersion(comctl32) >= ComCtlVersionIE6);
|
|
end;
|
|
|
|
function TWin32ThemeServices.ThemedControlsEnabled: Boolean;
|
|
var
|
|
Flags: DWORD;
|
|
begin
|
|
Flags := Win32UxTheme.GetThemeAppProperties();
|
|
if (Flags and STAP_ALLOW_CONTROLS) = 0 then
|
|
Result := False
|
|
else
|
|
Result := True;
|
|
end;
|
|
|
|
function TWin32ThemeServices.GetTheme(Element: TThemedElement): HTHEME;
|
|
begin
|
|
if (FThemeData[Element] = 0) then
|
|
begin
|
|
if (WindowsVersion >= wvVista) then
|
|
FThemeData[Element] := OpenThemeData(0, ThemeDataNamesVista[Element])
|
|
else
|
|
FThemeData[Element] := OpenThemeData(0, ThemeDataNames[Element]);
|
|
end;
|
|
Result := FThemeData[Element];
|
|
end;
|
|
|
|
function TWin32ThemeServices.InternalColorToRGB(Details: TThemedElementDetails; Color: TColor): LongInt;
|
|
begin
|
|
if ThemesEnabled then
|
|
Result := LongInt(GetThemeSysColor(Theme[Details.Element], Integer(Color and not $80000000)))
|
|
else
|
|
Result := inherited;
|
|
end;
|
|
|
|
function TWin32ThemeServices.ContentRect(DC: HDC; Details: TThemedElementDetails; BoundingRect: TRect): TRect;
|
|
begin
|
|
if ThemesEnabled then
|
|
with Details do
|
|
GetThemeBackgroundContentRect(Theme[Element], DC, Part, State, BoundingRect, @Result)
|
|
else
|
|
Result := inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.DrawEdge(DC: HDC; Details: TThemedElementDetails; const R: TRect; Edge, Flags: Cardinal;
|
|
AContentRect: PRect = nil);
|
|
begin
|
|
if ThemesEnabled then
|
|
with Details do
|
|
DrawThemeEdge(Theme[Element], DC, Part, State, R, Edge, Flags, AContentRect)
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.DrawElement(DC: HDC; Details: TThemedElementDetails; const R: TRect; ClipRect: PRect = nil);
|
|
var
|
|
ARect: TRect;
|
|
Brush: HBrush;
|
|
begin
|
|
if ThemesEnabled then
|
|
begin
|
|
if (Details.Element = teTreeview) and (Details.Part = TVP_HOTGLYPH) and (WindowsVersion < wvVista) then
|
|
Details.Part := TVP_GLYPH;
|
|
if (Details.Element = teTreeview) and (Details.Part = TVP_TREEITEM) and (WindowsVersion < wvVista) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
with Details do
|
|
DrawThemeBackground(Theme[Element], DC, Part, State, R, ClipRect);
|
|
if (Details.Element = teToolTip) and (Details.Part = TTP_STANDARD) and (WindowsVersion < wvVista) then
|
|
begin
|
|
// use native background on windows vista
|
|
ARect := ContentRect(DC, Details, R);
|
|
Brush := CreateSolidBrush(ColorToRGB(clInfoBk));
|
|
FillRect(DC, ARect, Brush);
|
|
DeleteObject(Brush);
|
|
end;
|
|
end
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.DrawIcon(DC: HDC; Details: TThemedElementDetails;
|
|
const R: TRect; himl: HIMAGELIST; Index: Integer);
|
|
begin
|
|
if ThemesEnabled then
|
|
with Details do
|
|
DrawThemeIcon(Theme[Element], DC, Part, State, R, himl, Index)
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.DrawIcon(ACanvas: TPersistent;
|
|
Details: TThemedElementDetails; const P: TPoint; AImageList: TPersistent;
|
|
Index: Integer);
|
|
{var
|
|
ImageList: TCustomImageList absolute AImageList;
|
|
}
|
|
begin
|
|
{ if ThemesEnabled then
|
|
DrawIcon(TCanvas(ACanvas).Handle, Details,
|
|
Rect(P.X, P.Y, P.X + ImageList.Width, P.Y + ImageList.Width),
|
|
ImageList.Handle, Index)
|
|
else}
|
|
inherited;
|
|
end;
|
|
|
|
function TWin32ThemeServices.HasTransparentParts(Details: TThemedElementDetails): Boolean;
|
|
begin
|
|
if ThemesEnabled then
|
|
with Details do
|
|
Result := IsThemeBackgroundPartiallyTransparent(Theme[Element], Part, State)
|
|
else
|
|
Result := inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.PaintBorder(Control: TObject;
|
|
EraseLRCorner: Boolean);
|
|
var
|
|
EmptyRect,
|
|
DrawRect: TRect;
|
|
DC: HDC;
|
|
H, W: Integer;
|
|
AStyle,
|
|
ExStyle: Integer;
|
|
Details: TThemedElementDetails;
|
|
begin
|
|
if not (Control is TWinControl) then
|
|
Exit;
|
|
|
|
if not ThemesEnabled then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
|
|
with TWinControl(Control) do
|
|
begin
|
|
ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);
|
|
if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then
|
|
begin
|
|
GetWindowRect(Handle, DrawRect);
|
|
OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);
|
|
DC := GetWindowDC(Handle);
|
|
try
|
|
EmptyRect := DrawRect;
|
|
if EraseLRCorner then
|
|
begin
|
|
AStyle := GetWindowLong(Handle, GWL_STYLE);
|
|
if ((AStyle and WS_HSCROLL) <> 0) and ((AStyle and WS_VSCROLL) <> 0) then
|
|
begin
|
|
W := GetSystemMetrics(SM_CXVSCROLL);
|
|
H := GetSystemMetrics(SM_CYHSCROLL);
|
|
InflateRect(EmptyRect, -2, -2);
|
|
with EmptyRect do
|
|
EmptyRect := Rect(Right - W, Bottom - H, Right, Bottom);
|
|
FillRect(DC, EmptyRect, GetSysColorBrush(COLOR_BTNFACE));
|
|
end;
|
|
end;
|
|
with DrawRect do
|
|
ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2);
|
|
Details := ThemeServices.GetElementDetails(teEditTextNormal);
|
|
DrawElement(DC, Details, DrawRect, nil);
|
|
finally
|
|
ReleaseDC(Handle, DC);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.InternalDrawParentBackground(Window: HWND;
|
|
Target: HDC; Bounds: PRect);
|
|
begin
|
|
if ThemesEnabled then
|
|
DrawThemeParentBackground(Window, Target, Bounds)
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.DrawText(DC: HDC; Details: TThemedElementDetails;
|
|
const S: String; R: TRect; Flags, Flags2: Cardinal);
|
|
{$IFDEF WindowsUnicodeSupport}
|
|
var
|
|
w: widestring;
|
|
{$ENDIF}
|
|
begin
|
|
if ThemesEnabled then
|
|
with Details do
|
|
{$IFDEF WindowsUnicodeSupport}
|
|
begin
|
|
w := UTF8ToUTF16(S);
|
|
DrawThemeText(Theme[Element], DC, Part, State, PWideChar(w), Length(w), Flags, Flags2, R);
|
|
end
|
|
{$ELSE}
|
|
DrawThemeText(Theme[Element], DC, Part, State, PWideChar(WideString(S)), Length(S), Flags, Flags2, R)
|
|
{$ENDIF}
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.DrawText(ACanvas: TPersistent;
|
|
Details: TThemedElementDetails; const S: String; R: TRect; Flags,
|
|
Flags2: Cardinal);
|
|
begin
|
|
if (Details.Element = teTreeview) and (Details.Part = TVP_TREEITEM) and (WindowsVersion < wvVista) then
|
|
begin
|
|
inherited;
|
|
Exit;
|
|
end;
|
|
if ThemesEnabled then
|
|
DrawText(TCanvas(ACanvas).Handle, Details, S, R, Flags, Flags2)
|
|
else
|
|
inherited;
|
|
end;
|
|
|
|
procedure TWin32ThemeServices.DrawTextEx(DC: HDC;
|
|
Details: TThemedElementDetails; const S: String; R: TRect; Flags: Cardinal;
|
|
Options: PDTTOpts);
|
|
{$IFDEF WindowsUnicodeSupport}
|
|
var
|
|
w: widestring;
|
|
{$ENDIF}
|
|
begin
|
|
if ThemesEnabled and (DrawThemeTextEx <> nil) then
|
|
with Details do
|
|
{$IFDEF WindowsUnicodeSupport}
|
|
begin
|
|
w := UTF8ToUTF16(S);
|
|
DrawThemeTextEx(Theme[Element], DC, Part, State, PWideChar(w), Length(w), Flags, @R, Options);
|
|
end
|
|
{$ELSE}
|
|
DrawThemeTextEx(Theme[Element], DC, Part, State, PWideChar(WideString(S)), Length(S), Flags, @R, Options)
|
|
{$ENDIF}
|
|
else
|
|
DrawText(DC, Details, S, R, Flags, 0);
|
|
end;
|
|
|
|
end.
|