Archivado/Componentes.Terceros.TB2k-TBX
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
cd664460a2
Componentes.Terceros.TB2k-TBX/official/2.1.6+2.1.beta1/TBX/TBXThemes.pas

898 lines
29 KiB
ObjectPascal
Raw Blame History

unit TBXThemes;
// TBX Package
// Copyright 2001-2004 Alex A. Denisov. All Rights Reserved
// See TBX.chm for license and installation instructions
//
// $Id: TBXThemes.pas 16 2004-05-26 02:02:55Z Alex@ZEISS $
interface
{$I ..\..\Source\TB2Ver.inc}
{$I TBX.inc}
uses
Windows, Messages, Classes, Forms, Graphics, ImgList;
{ TBX_SYSCOMMAND message }
const
TBX_SYSCOMMAND = WM_USER + 312;
TSC_BEFOREVIEWCHANGE = 1;
TSC_VIEWCHANGE = 2;
TSC_AFTERVIEWCHANGE = 3;
TSC_APPACTIVATE = 4;
TSC_APPDEACTIVATE = 5;
{ Integer Metric IDs }
const
TMI_SPLITBTN_ARROWWIDTH = 10;
TMI_DROPDOWN_ARROWWIDTH = 20;
TMI_DROPDOWN_ARROWMARGIN = 21;
TMI_MENU_IMGTEXTSPACE = 32;
TMI_MENU_LCAPTIONMARGIN = 33;
TMI_MENU_RCAPTIONMARGIN = 34;
TMI_MENU_SEPARATORSIZE = 35;
TMI_MENU_MDI_DW = 36;
TMI_MENU_MDI_DH = 37;
TMI_TLBR_SEPARATORSIZE = 50;
TMI_EDIT_FRAMEWIDTH = 60;
TMI_EDIT_TEXTMARGINHORZ = 61;
TMI_EDIT_TEXTMARGINVERT = 62;
TMI_EDIT_BTNWIDTH = 65;
TMI_EDIT_MENURIGHTINDENT = 66;
{ Boolean Metric IDs }
const
TMB_OFFICEXPPOPUPALIGNMENT = 1;
TMB_EDITMENUFULLSELECT = 3; // highlights the full edit item
TMB_EDITHEIGHTEVEN = 4; // forces the height of the edit item to be even number (otherwise it will be odd)
TMB_PAINTDOCKBACKGROUND = 5; // docks are painted by the theme instead of having a uniform color
TMB_SOLIDTOOLBARNCAREA = 6; // no transparency in NC area of toolbars
TMB_SOLIDTOOLBARCLIENTAREA = 7; // no transparency in client area of toolbars
TMB_SOLIDTOOLBARS = TMB_SOLIDTOOLBARNCAREA; // for compatibility only
{ Margins Metric IDs}
const
MID_TOOLBARITEM = 1;
MID_MENUITEM = 2;
MID_STATUSPANE = 3;
{ View types }
const
VT_UNKNOWN = $0;
VT_TOOLBAR = $01000;
VT_POPUP = $02000;
VT_DOCKPANEL = $04000;
VT_DOCKWINDOW = $08000;
VT_STATUSBAR = $10000; // technicaly, this is not a view
{ Toolbar view types }
TVT_FLOATING = $800;
TVT_RESIZABLE = $400; // valid only when floating
TVT_EMBEDDED = $200; // when the toolbar is not floating or docked
TVT_NORMALTOOLBAR = VT_TOOLBAR or $01;
TVT_MENUBAR = VT_TOOLBAR or $02;
TVT_TOOLWINDOW = VT_TOOLBAR or $04;
{ Popup view types }
PVT_POPUPMENU = VT_POPUP or $01;
PVT_LISTBOX = VT_POPUP or $02;
PVT_TOOLBOX = VT_POPUP or $04;
PVT_CHEVRONMENU = VT_POPUP or $08;
{ Dockable panel view types }
DPVT_FLOATING = $800;
DPVT_RESIZABLE = $400;
DPVT_NORMAL = VT_DOCKPANEL or $01;
{ Dockable window view types }
DWVT_FLOATING = $800;
DWVT_RESIZABLE = $400;
DWVT_NORMAL = VT_DOCKWINDOW or $01;
{ Item types }
const
IT_TOOLBARBUTTON = 1;
IT_MENUITEM = 2;
{ Item options (bit flags) }
const
IO_TOOLBARSTYLE = $01;
IO_SUBMENUITEM = $04;
IO_COMBO = $08;
IO_DESIGNING = $10;
IO_APPACTIVE = $20; // True when Application.Active = True
IO_RADIO = $40;
{ Drag handle styles }
const
DHS_DOUBLE = 0;
DHS_NONE = 1;
DHS_SINGLE = 2;
{ Caption/drag handle button states (bit flags) }
const
CDBS_VISIBLE = $1;
CDBS_HOT = $2;
CDBS_PRESSED = $4;
{ Window info's RedrawPart (bit flags) }
const
WRP_BORDER = $1;
WRP_CAPTION = $2;
WRP_CLOSEBTN = $4;
{ Popup shadow types }
const
PST_NONE = 0; // no popup shadows
PST_WINDOWSXP = 1;
PST_OFFICEXP = 2;
PST_WINDOWS2K = 3;
{ Edit (ComboBox) button types }
const
EBT_DROPDOWN = 1;
EBT_SPIN = 2;
{ Edit (ComboBox) button states for EBT_DROPDOWN type (bit flags) }
EBDS_DISABLED = $1;
EBDS_HOT = $2;
EBDS_PRESSED = $4;
{ Edit (ComboBox) button states for EBT_SPIN type (bit flags) }
EBSS_DISABLED = $1;
EBSS_HOT = $2;
EBSS_UP = $4;
EBSS_DOWN = $8;
{ Page scroll button types }
const
PSBT_UP = 1;
PSBT_DOWN = 2;
PSBT_LEFT = 3;
PSBT_RIGHT = 4;
{ PaintFrameControl kinds }
const
PFC_CHECKBOX = 1;
PFC_RADIOBUTTON = 2;
{ PaintFrameControl states }
PFS_CHECKED = $01;
PFS_MIXED = $02;
PFS_DISABLED = $04;
PFS_HOT = $08;
PFS_PUSHED = $10;
PFS_FOCUSED = $20;
{ Item state flags }
const
ISF_DISABLED = $001;
ISF_HOT = $002;
ISF_PUSHED = $004;
ISF_SELECTED = $008;
ISF_LOCATIONMASK = $F00;
ISF_TOOLBARCOLOR = $000; // for text and images painted in toolbars
ISF_MENUCOLOR = $100; // for text and images painted in popups and DkPanels
ISF_STATUSCOLOR = $200; // for text and images painted in status bars
{ StatusBar parts }
const
SBP_BODY = 0;
SBP_PANE = 1;
SBP_LASTPANE = 2;
SBP_GRIPPER = 3;
{ Dock positions }
const
DP_TOP = 1;
DP_BOTTOM = 2;
DP_LEFT = 3;
DP_RIGHT = 4;
type
TTBXItemLayout = (tbxlAuto, tbxlGlyphLeft, tbxlGlyphTop);
TTBXMargins = record
LeftWidth: Integer;
RightWidth: Integer;
TopHeight: Integer;
BottomHeight: Integer;
end;
TTBXHoverKind = (hkNone, hkKeyboardHover, hkMouseHover);
TTBXComboPart = (cpNone, cpCombo, cpSplitLeft, cpSplitRight);
TTBXItemInfo = record
ViewType: Integer; // VT_*, TVT_*, PVT_*, or DPVT_* constant
ItemOptions: Integer; // IO_* flags
Enabled: Boolean;
Pushed: Boolean;
HoverKind: TTBXHoverKind;
Selected: Boolean;
ImageShown: Boolean;
ImageWidth: Integer;
ImageHeight: Integer;
IsVertical: Boolean;
ComboPart: TTBXComboPart;
IsPopupParent: Boolean; // used in officexp theme
PopupMargin: Integer;
AppFlags: Integer; // reserved for extensions
AppData: Integer;
end;
TTBXWindowInfo = record
ParentHandle: HWND; // handle of a parent floating window
WindowHandle: HWND; // handle of a toolbar or dockable panel
ViewType: Integer; // TVT_* or DPVT_* view types (loating)
ClientWidth: Integer;
ClientHeight: Integer;
ShowCaption: Boolean;
FloatingBorderSize: TPoint;
CloseButtonState: Integer; // CDBS_* state flags
RedrawPart: Integer; // WRP_ constants
Caption: PChar;
EffectiveColor: TColor;
Active: Boolean;
AppFlags: Integer; // reserved for extensions
AppData: Integer;
end;
TTBXPopupInfo = record
WindowHandle: HWND;
ViewType: Integer;
ParentRect: TRect;
BorderSize: TPoint;
AppFlags: Integer; // reserved for extensions
AppData: Integer;
end;
TTBXToolbarInfo = record
WindowHandle: HWND;
ViewType: Integer; // TVT_* view types (docked)
IsVertical: Boolean;
AllowDrag: Boolean;
BorderStyle: TBorderStyle;
BorderSize: TPoint;
ClientWidth: Integer;
ClientHeight: Integer;
DragHandleStyle: Integer;
CloseButtonState: Integer; // CDBS_* state flags
Caption: PChar;
EffectiveColor: TColor;
AppFlags: Integer; // reserved for extensions
AppData: Integer;
end;
TTBXDockPanelInfo = record
WindowHandle: HWND;
ViewType: Integer; // DPVT_* view types (docked)
IsVertical: Boolean;
AllowDrag: Boolean;
BorderStyle: TBorderStyle;
BorderSize: TPoint;
ClientWidth: Integer;
ClientHeight: Integer;
ShowCaption: Boolean;
CloseButtonState: Integer;
Caption: PChar;
EffectiveColor: TColor;
AppFlags: Integer; // reserved for extensions
AppData: Integer;
end;
TTBXEditBtnInfo = record
ButtonType: Integer; // EBT_* button type
ButtonState: Integer;
end;
TTBXEditInfo = record
LeftBtnWidth: Integer;
RightBtnWidth: Integer;
LeftBtnInfo: TTBXEditBtnInfo; // valid only if LeftBtnWidth > 0
RightBtnInfo: TTBXEditBtnInfo; // valid only if RightBtnWidth > 0
end;
TTBXTheme = class
private
FName: string;
FTag: Integer;
public
constructor Create(const AName: string); virtual;
{ Margins, color, etc. }
function GetImageOffset(Canvas: TCanvas; const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList): TPoint; virtual; abstract;
function GetItemColor(const ItemInfo: TTBXItemInfo): TColor; virtual; abstract;
function GetItemTextColor(const ItemInfo: TTBXItemInfo): TColor; virtual; abstract;
function GetItemImageBackground(const ItemInfo: TTBXItemInfo): TColor; virtual; abstract;
procedure GetMargins(MarginID: Integer; out Margins: TTBXMargins); virtual; abstract;
function GetPopupShadowType: Integer; virtual; abstract; // returns one of the PST_ constants
procedure GetViewBorder(ViewType: Integer; out Border: TPoint); virtual; abstract;
function GetViewColor(ViewType: Integer): TColor; virtual; abstract;
procedure GetViewMargins(ViewType: Integer; out Margins: TTBXMargins); virtual; abstract;
{ General painting routines }
procedure PaintBackgnd(Canvas: TCanvas; const ADockRect, ARect, AClipRect: TRect; AColor: TColor; Transparent: Boolean; AViewType: Integer); virtual; abstract;
procedure PaintButton(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); virtual; abstract;
procedure PaintCaption(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo; const ACaption: string; AFormat: Cardinal; Rotated: Boolean); virtual; abstract;
procedure PaintCheckMark(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); virtual; abstract;
procedure PaintChevron(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo); virtual; abstract;
procedure PaintEditFrame(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo; const EditInfo: TTBXEditInfo); virtual; abstract;
procedure PaintEditButton(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo; ButtonInfo: TTBXEditBtnInfo); virtual; abstract;
procedure PaintDock(Canvas: TCanvas; const ClientRect, DockRect: TRect; DockPosition: Integer); virtual; abstract;
procedure PaintDockPanelNCArea(Canvas: TCanvas; R: TRect; const DockPanelInfo: TTBXDockPanelInfo); virtual; abstract;
procedure PaintDropDownArrow(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); virtual; abstract;
procedure PaintFloatingBorder(Canvas: TCanvas; const ARect: TRect; const WindowInfo: TTBXWindowInfo); virtual; abstract;
procedure PaintFrame(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); virtual; abstract;
procedure PaintImage(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo; ImageList: TCustomImageList; ImageIndex: Integer); virtual; abstract;
procedure PaintMDIButton(Canvas: TCanvas; ARect: TRect; const ItemInfo: TTBXItemInfo; ButtonKind: Cardinal); virtual; abstract;
procedure PaintMenuItem(Canvas: TCanvas; const ARect: TRect; var ItemInfo: TTBXItemInfo); virtual; abstract;
procedure PaintMenuItemFrame(Canvas: TCanvas; const ARect: TRect; const ItemInfo: TTBXItemInfo); virtual; abstract;
procedure PaintPageScrollButton(Canvas: TCanvas; const ARect: TRect; ButtonType: Integer; Hot: Boolean); virtual; abstract;
procedure PaintPopupNCArea(Canvas: TCanvas; R: TRect; const PopupInfo: TTBXPopupInfo); virtual; abstract;
procedure PaintSeparator(Canvas: TCanvas; ARect: TRect; ItemInfo: TTBXItemInfo; Horizontal, LineSeparator: Boolean); virtual; abstract;
procedure PaintToolbarNCArea(Canvas: TCanvas; R: TRect; const WindowInfo: TTBXToolbarInfo); virtual; abstract;
procedure PaintFrameControl(Canvas: TCanvas; R: TRect; Kind, State: Integer; Params: Pointer); virtual; abstract;
procedure PaintStatusBar(Canvas: TCanvas; R: TRect; Part: Integer); virtual; abstract;
{ Integer metrics access }
function GetIntegerMetrics(Index: Integer): Integer; virtual; abstract;
property SplitBtnArrowWidth: Integer index TMI_SPLITBTN_ARROWWIDTH read GetIntegerMetrics;
property DropdownArrowWidth: Integer index TMI_DROPDOWN_ARROWWIDTH read GetIntegerMetrics;
property DropdownArrowMargin: Integer index TMI_DROPDOWN_ARROWMARGIN read GetIntegerMetrics;
property MenuImageTextSpace: Integer index TMI_MENU_IMGTEXTSPACE read GetIntegerMetrics;
property MenuLeftCaptionMargin: Integer index TMI_MENU_LCAPTIONMARGIN read GetIntegerMetrics;
property MenuRightCaptionMargin: Integer index TMI_MENU_RCAPTIONMARGIN read GetIntegerMetrics;
property MenuSeparatorSize: Integer index TMI_MENU_SEPARATORSIZE read GetIntegerMetrics;
property MenuMDIDW: Integer index TMI_MENU_MDI_DW read GetIntegerMetrics;
property MenuMDIDH: Integer index TMI_MENU_MDI_DH read GetIntegerMetrics;
property TlbrSeparatorSize: Integer index TMI_TLBR_SEPARATORSIZE read GetIntegerMetrics;
property EditFrameWidth: Integer index TMI_EDIT_FRAMEWIDTH read GetIntegerMetrics;
property EditTextMarginHorz: Integer index TMI_EDIT_TEXTMARGINHORZ read GetIntegerMetrics;
property EditTextMarginVert: Integer index TMI_EDIT_TEXTMARGINVERT read GetIntegerMetrics;
property EditBtnWidth: Integer index TMI_EDIT_BTNWIDTH read GetIntegerMetrics;
property EditMenuRightIndent: Integer index TMI_EDIT_MENURIGHTINDENT read GetIntegerMetrics;
{ Boolean metrics access }
function GetBooleanMetrics(Index: Integer): Boolean; virtual; abstract;
property OfficeXPPopupAlignment: Boolean index TMB_OFFICEXPPOPUPALIGNMENT read GetBooleanMetrics;
property EditMenuFullSelect: Boolean index TMB_EDITMENUFULLSELECT read GetBooleanMetrics;
property EditHeightEven: Boolean index TMB_EDITHEIGHTEVEN read GetBooleanMetrics;
property PaintDockBackground: Boolean index TMB_PAINTDOCKBACKGROUND read GetBooleanMetrics;
property SolidToolbarNCArea: Boolean index TMB_SOLIDTOOLBARNCAREA read GetBooleanMetrics;
property SolidToolbarClientArea: Boolean index TMB_SOLIDTOOLBARCLIENTAREA read GetBooleanMetrics;
property Name: string read FName;
property Tag: Integer read FTag write FTag;
end;
TTBXThemeClass = class of TTBXTheme;
const
{ TBXSysParam Params }
TSP_FLATMENUSTYLE = 1;
TSP_XPVISUALSTYLE = 2;
{ Flat menu styles }
FMS_AUTOMATIC = 0;
FMS_DISABLED = 1;
FMS_ENABLED = 2;
{ XP visual styles}
XPVS_AUTOMATIC = 0;
XPVS_DISABLED = 2;
procedure SetTBXSysParam(Param: Integer; Value: Integer);
function GetTBXSysParam(Param: Integer): Integer;
procedure AddTBXSysChangeNotification(AObject: TObject);
procedure RemoveTBXSysChangeNotification(AObject: TObject);
procedure RegisterTBXTheme(const AName: string; AThemeClass: TTBXThemeClass);
procedure UnregisterTBXTheme(const AName: string);
function IsTBXThemeAvailable(const AName: string): Boolean;
procedure GetAvailableTBXThemes(Strings: TStrings);
function GetTBXTheme(const AName: string): TTBXTheme;
procedure ReleaseTBXTheme(var ATheme: TTBXTheme);
{ Additional "system" variables - do not change }
var
{ Additional colors }
clHotLight: TColor;
clPopup: TColor;
clPopupText: TColor;
clToolbar: TColor;
clToolbarText: TColor;
{ Auxiliary flags corresponding to the system color scheme }
TBXLoColor: Boolean;
TBXHiContrast: Boolean; // this can me removed in future
TBXNoBlending: Boolean; // TBXNoColor or TBXHiContrast
{ Handles for Windows XP visual styles }
SCROLLBAR_THEME: THandle;
REBAR_THEME: THandle;
BUTTON_THEME: THandle;
TOOLBAR_THEME: THandle;
WINDOW_THEME: THandle;
COMBO_THEME: THandle;
EXPLORERBAR_THEME: THandle;
STATUSBAR_THEME: THandle;
SPIN_THEME: THandle;
var
USE_FLATMENUS: Boolean;
USE_THEMES: Boolean;
{ Misc. Functions }
{ Warning: These functions may be changed or relocated in future versions }
function GetTBXCaptionRect(const WindowInfo: TTBXWindowInfo; AdjustForBorder, MinusCloseButton: Boolean): TRect;
function GetTBXCloseButtonRect(const WindowInfo: TTBXWindowInfo; AdjustForBorder: Boolean): TRect;
function GetTBXDockedCloseButtonRect(const ToolbarInfo: TTBXToolbarInfo): TRect;
function GetTBXDragHandleSize(const ToolbarInfo: TTBXToolbarInfo): Integer;
implementation
uses
SysUtils, TBXUtils, TBXUxThemes;
const
SPI_GETFLATMENU = $1022;
type
TThemeInfo = record
Name: ShortString;
ThemeClass: TTBXThemeClass;
ThemeInstance: TTBXTheme;
RefCount: Integer;
end;
var
Themes: array of TThemeInfo;
{ TTBXThemeManager }
type
TTBXThemeManager = class
private
FEnableVisualStyles: Boolean;
FFlatMenuStyle: Integer;
FNotifies: TList;
FWindowHandle: HWND;
procedure SetEnableVisualStyles(Value: Boolean);
procedure SetFlatMenuStyle(Value: Integer);
protected
procedure VisualStylesClose;
procedure VisualStylesOpen;
procedure UpdateVariables;
procedure WndProc(var Message: TMessage);
public
constructor Create;
destructor Destroy; override;
function Broadcast(Msg: Cardinal; Param1, Param2: Integer): Integer;
procedure Notify;
procedure AddNotification(AObject: TObject);
procedure RemoveNotification(AObject: TObject);
property EnableVisualStyles: Boolean read FEnableVisualStyles write SetEnableVisualStyles;
property FlatMenuStyle: Integer read FFlatMenuStyle write SetFlatMenuStyle;
end;
var
ThemeManager: TTBXThemeManager;
procedure SetTBXSysParam(Param: Integer; Value: Integer);
begin
case Param of
TSP_FLATMENUSTYLE: ThemeManager.FlatMenuStyle := Value;
TSP_XPVISUALSTYLE: ThemeManager.EnableVisualStyles := (Value = XPVS_AUTOMATIC);
end;
end;
function GetTBXSysParam(Param: Integer): Integer;
const
CXPVStyles: array [Boolean] of Integer = (XPVS_DISABLED, XPVS_AUTOMATIC);
begin
Assert(ThemeManager <> nil);
case Param of
TSP_FLATMENUSTYLE: Result := ThemeManager.FlatMenuStyle;
TSP_XPVISUALSTYLE: Result := CXPVStyles[ThemeManager.EnableVisualStyles];
else
Result := -1;
end;
end;
procedure AddTBXSysChangeNotification(AObject: TObject);
begin
ThemeManager.AddNotification(AObject);
end;
procedure RemoveTBXSysChangeNotification(AObject: TObject);
begin
ThemeManager.RemoveNotification(AObject);
end;
function FindTBXTheme(const AName: string): Integer;
begin
for Result := 0 to Length(Themes) - 1 do
if CompareText(Themes[Result].Name, AName) = 0 then Exit;
Result := -1;
end;
procedure RegisterTBXTheme(const AName: string; AThemeClass: TTBXThemeClass);
var
Index: Integer;
begin
if (Length(AName) = 0) or (AThemeClass = nil) then
raise Exception.Create('Cannot register theme');
Index := FindTBXTheme(AName);
if Index >= 0 then raise Exception.CreateFmt('Theme %s is already registered', [AName]);
Index := Length(Themes);
SetLength(Themes, Index + 1);
with Themes[Index] do
begin
Name := AName;
ThemeClass := AThemeClass;
ThemeInstance := nil;
RefCount := 0;
end;
end;
procedure UnregisterTBXTheme(const AName: string);
var
Index, L: Integer;
begin
Index := FindTBXTheme(AName);
if Index < 0 then raise Exception.CreateFmt('Cannot unregister unknown theme %s', [AName]);
L := Length(Themes);
if Index < L - 1 then
Move(Themes[Index + 1], Themes[Index], SizeOf(TThemeInfo) * (L - Index - 1));
SetLength(Themes, L - 1);
end;
function IsTBXThemeAvailable(const AName: string): Boolean;
begin
Result := FindTBXTheme(AName) >= 0;
end;
procedure GetAvailableTBXThemes(Strings: TStrings);
var
I: Integer;
begin
Assert(Strings <> nil);
for I := 0 to Length(Themes) - 1 do
Strings.Add(Themes[I].Name);
end;
function GetTBXTheme(const AName: string): TTBXTheme;
const
ActiveFlags: array [Boolean] of Integer = (TSC_APPDEACTIVATE, TSC_APPACTIVATE);
var
Index: Integer;
M: TMessage;
begin
Index := FindTBXTheme(AName);
if Index < 0 then raise Exception.Create('Unknown theme ' + AName);
with Themes[Index] do
begin
if RefCount = 0 then
begin
{ Create a new instance and increase reference count }
Assert(ThemeInstance = nil);
ThemeInstance := ThemeClass.Create(Name);
M.Msg := TBX_SYSCOMMAND;
M.WParam := Integer(Application.Active);
M.LParam := 0;
M.Result := 0;
ThemeInstance.Dispatch(M);
end;
Inc(RefCount);
Result := ThemeInstance;
end;
end;
procedure ReleaseTBXTheme(var ATheme: TTBXTheme);
var
Index: Integer;
begin
for Index := 0 to Length(Themes) - 1 do
with Themes[Index] do
if ThemeInstance = ATheme then
begin
if RefCount < 1 then raise Exception.Create('Cannot release theme ' + Themes[Index].Name);
Dec(RefCount);
if RefCount = 0 then
begin
ThemeInstance.Free;
ThemeInstance := nil;
ATheme := nil;
end;
Exit;
end;
raise Exception.Create('Cannot release theme');
end;
{ TTBXTheme }
constructor TTBXTheme.Create(const AName: string);
begin
FName := AName;
end;
{ Misc. Functions }
function GetTBXCaptionRect(const WindowInfo: TTBXWindowInfo;
AdjustForBorder, MinusCloseButton: Boolean): TRect;
begin
Result := Rect(0, 0, WindowInfo.ClientWidth, GetSystemMetrics(SM_CYSMCAPTION) - 1);
if MinusCloseButton then Dec(Result.Right, Result.Bottom);
if AdjustForBorder then
with WindowInfo.FloatingBorderSize do OffsetRect(Result, X, Y);
end;
function GetTBXCloseButtonRect(const WindowInfo: TTBXWindowInfo;
AdjustForBorder: Boolean): TRect;
begin
Result := GetTBXCaptionRect(WindowInfo, AdjustForBorder, False);
Result.Left := Result.Right - Result.Bottom + Result.Top;
end;
function GetTBXDockedCloseButtonRect(const ToolbarInfo: TTBXToolbarInfo): TRect;
const
DragHandleSizes: array [Boolean, 0..2] of Integer = ((9, 0, 6), (14, 14, 14));
var
X, Y, Z: Integer;
begin
with ToolbarInfo do
begin
Z := GetTBXDragHandleSize(ToolbarInfo) - 1;
if not IsVertical then
begin
X := BorderSize.X;
Y := BorderSize.Y;
end
else
begin
X := (ClientWidth + BorderSize.X) - Z;
Y := BorderSize.Y;
end;
Result := Bounds(X, Y, Z, Z);
end;
end;
function GetTBXDragHandleSize(const ToolbarInfo: TTBXToolbarInfo): Integer;
const
DragHandleSizes: array [Boolean, 0..2] of Integer = ((9, 0, 6), (14, 14, 14));
begin
with ToolbarInfo do
begin
if AllowDrag then
Result := DragHandleSizes[(CloseButtonState and CDBS_VISIBLE) <> 0, DragHandleStyle]
else
Result := 0;
end;
end;
{ TTBXThemeManager }
procedure TTBXThemeManager.AddNotification(AObject: TObject);
begin
FNotifies.Add(AObject);
end;
function TTBXThemeManager.Broadcast(Msg: Cardinal; Param1, Param2: Integer): Integer;
var
I: Integer;
M: TMessage;
begin
if FNotifies.Count > 0 then
begin
M.Msg := Msg;
M.WParam := Param1;
M.LParam := Param2;
M.Result := 0;
for I := 0 to FNotifies.Count - 1 do TObject(FNotifies[I]).Dispatch(M);
Result := M.Result;
end
else Result := 0;
end;
constructor TTBXThemeManager.Create;
begin
FEnableVisualStyles := True;
FFlatMenuStyle := FMS_AUTOMATIC;
FNotifies := TList.Create;
FWindowHandle := {$IFDEF JR_D6}Classes.{$ENDIF}AllocateHWnd(WndProc);
UpdateVariables;
end;
destructor TTBXThemeManager.Destroy;
begin
VisualStylesClose;
{$IFDEF JR_D6}Classes.{$ENDIF}DeallocateHWnd(FWindowHandle);
FNotifies.Free;
VisualStylesClose;
inherited;
end;
procedure TTBXThemeManager.Notify;
begin
if FNotifies.Count > 0 then
begin
Broadcast(TBX_SYSCOMMAND, TSC_BEFOREVIEWCHANGE, 0);
Broadcast(TBX_SYSCOMMAND, TSC_VIEWCHANGE, 0);
Broadcast(TBX_SYSCOMMAND, TSC_AFTERVIEWCHANGE, 0);
end;
end;
procedure TTBXThemeManager.RemoveNotification(AObject: TObject);
begin
FNotifies.Remove(AObject);
end;
procedure TTBXThemeManager.SetEnableVisualStyles(Value: Boolean);
begin
if Value <> FEnableVisualStyles then
begin
FEnableVisualStyles := Value;
UpdateVariables;
Notify;
end;
end;
procedure TTBXThemeManager.SetFlatMenuStyle(Value: Integer);
begin
if Value <> FFlatMenuStyle then
begin
FFlatMenuStyle := Value;
UpdateVariables;
Notify;
end;
end;
procedure TTBXThemeManager.UpdateVariables;
var
DC: HDC;
SysFlatMenus: Boolean;
begin
TBXUtils.RecreateStock;
DC := GetDC(0);
try
TBXLoColor := GetDeviceCaps(DC, BITSPIXEL) * GetDeviceCaps(DC, PLANES) < 12;
TBXHiContrast := GetSysColor(COLOR_BTNFACE) = $00FFFFFF;
TBXNoBlending := TBXLoColor or TBXHiContrast;
finally
ReleaseDC(0, DC);
end;
VisualStylesClose;
VisualStylesOpen;
clToolbar := clBtnFace;
clToolbarText := clBtnText;
if USE_THEMES then
begin
GetThemeColor(TOOLBAR_THEME, 0, 0, TMT_FILLCOLOR, Cardinal(clToolbar));
GetThemeColor(TOOLBAR_THEME, 0, 0, TMT_TEXTCOLOR, Cardinal(clToolbarText));
end;
SysFlatMenus := False;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and
((Win32MajorVersion > 5) or
((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))) then
begin
SystemParametersInfo(SPI_GETFLATMENU, 0, @SysFlatMenus, 0);
end;
if SysFlatMenus then // System indicates support for flat menus
begin
if FlatMenuStyle in [FMS_AUTOMATIC, FMS_ENABLED] then
begin
USE_FLATMENUS := True;
clPopup := clMenu;
clPopupText := clMenuText;
end
else
begin
USE_FLATMENUS := False;
clPopup := clToolbar;
clPopupText := clToolbarText;
end;
end
else
begin
if FlatMenuStyle = FMS_ENABLED then
begin
USE_FLATMENUS := True;
clPopup := clWindow;
clPopupText := clWindowText;
end
else
begin
USE_FLATMENUS := False;
clPopup := clMenu;
clPopupText := clMenuText;
end;
end;
end;
procedure TTBXThemeManager.VisualStylesClose;
procedure Close(var ATheme: THandle);
begin
if ATheme <> 0 then begin CloseThemeData(ATheme); ATheme := 0; end;
end;
begin
if USE_THEMES then
begin
Close(BUTTON_THEME);
Close(SCROLLBAR_THEME);
Close(REBAR_THEME);
Close(TOOLBAR_THEME);
Close(WINDOW_THEME);
Close(COMBO_THEME);
Close(EXPLORERBAR_THEME);
Close(STATUSBAR_THEME);
Close(SPIN_THEME);
end;
FreeXPThemes;
end;
procedure TTBXThemeManager.VisualStylesOpen;
begin
USE_THEMES := False;
if (Win32Platform = VER_PLATFORM_WIN32_NT) and ((Win32MajorVersion > 5) or
((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))) and EnableVisualStyles then
begin
InitXPThemes;
USE_THEMES := CanUseXPThemes;
try
BUTTON_THEME := OpenThemeData(FWindowHandle, 'BUTTON');
SCROLLBAR_THEME := OpenThemeData(FWindowHandle, 'SCROLLBAR');
REBAR_THEME := OpenThemeData(FWindowHandle, 'REBAR');
TOOLBAR_THEME := OpenThemeData(FWindowHandle, 'TOOLBAR');
WINDOW_THEME := OpenThemeData(FWindowHandle, 'WINDOW');
COMBO_THEME := OpenThemeData(FWindowHandle, 'COMBOBOX');
EXPLORERBAR_THEME := OpenThemeData(FWindowHandle, 'EXPLORERBAR');
STATUSBAR_THEME := OpenThemeData(FWindowHandle, 'STATUS');
SPIN_THEME := OpenThemeData(FWindowHandle, 'SPIN');
except
VisualStylesClose;
end;
end;
end;
procedure TTBXThemeManager.WndProc(var Message: TMessage);
const
ActiveFlags: array [Boolean] of Integer = (TSC_APPDEACTIVATE, TSC_APPACTIVATE);
begin
case Message.Msg of
WM_DISPLAYCHANGE, WM_SYSCOLORCHANGE, WM_THEMECHANGED:
begin
UpdateVariables;
ResetBrushedFillCache;
Notify;
end;
WM_ACTIVATEAPP:
Broadcast(TBX_SYSCOMMAND, ActiveFlags[Boolean(Message.WParam)], 0);
end;
with Message do Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam);
end;
initialization
if GetSysColorBrush(COLOR_HOTLIGHT) = 0 then clHotLight := clHighlight
else clHotLight := TColor($80000000 or 26);
Themes := nil;
ThemeManager := TTBXThemeManager.Create;
finalization
ThemeManager.Free;
SetLength(Themes, 0);
end.
Reference in New Issue View Git Blame Copy Permalink