pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
901b92fa7253da596d484795c088fd52c0c54b41
lazarus-ccr/components/jvcllaz/run/JvCore/jvthemes.pas

1046 lines
33 KiB
ObjectPascal
Raw Blame History

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvThemes.PAS, released on 2003-09-25
The Initial Developers of the Original Code are: Andreas Hausladen <Andreas dott Hausladen att gmx dott de>
All Rights Reserved.
Contributors:
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvThemes;
{$mode objfpc}{$H+}
{$DEFINE JVCLThemesEnabled}
{$DEFINE COMPILER7_UP}
interface
uses
LCLType, LCLIntf, LMessages,
//Types,
SysUtils, Classes,
{$IFDEF JVCLThemesEnabled}
Themes,
{$ENDIF JVCLThemesEnabled}
Controls, Forms, Graphics, Buttons;
(************************************** NOT CONVERTED ***
const
// Add a message handler to a component that is themed by the ThemeManager but
// should not be themed.
CM_DENYSUBCLASSING = CM_BASE + 2000; // from ThemeMgr.pas
type
TCMDenySubClassing = TMessage;
{$IFDEF JVCLThemesEnabled}
{$IFNDEF COMPILER16_UP}
type
TElementSize = (esMinimum, esActual, esStretch);
{$ELSE}
esMinimum = TElementSize.esStretch;
esActual = TElementSize.esActual;
esStretch = TElementSize.esStretch;
{$ENDIF ~COMPILER16_UP}
************)
type
TThemeServicesEx = class(TThemeServices)
(*************** NOT CONVERTED ***
{$IFNDEF COMPILER16_UP}
private
function DoGetElementSize(DC: HDC; Details: TThemedElementDetails; Rect: PRect;
ElementSize: TElementSize; out Size: TSize): Boolean;
{$ENDIF ~COMPILER16_UP}
*******************)
public
(****************
{$IFNDEF COMPILER7_UP}
procedure ApplyThemeChange;
{$ENDIF ~COMPILER7_UP}
{$IFNDEF COMPILER16_UP}
function GetElementContentRect(DC: HDC; Details: TThemedElementDetails;
const BoundingRect: TRect; out AContentRect: TRect): Boolean;
function GetElementSize(DC: HDC; Details: TThemedElementDetails; ElementSize: TElementSize;
out Size: TSize): Boolean; overload;
function GetElementSize(DC: HDC; Details: TThemedElementDetails; const Rect: TRect;
ElementSize: TElementSize; out Size: TSize): Boolean; overload;
********************)
function IsSystemStyle: Boolean;
function Enabled: Boolean;
function Available: Boolean;
(********************
function GetSystemColor(Color: TColor): TColor;
{$ENDIF ~COMPILER16_UP}
****************)
end;
function ThemeServices: TThemeServicesEx;
function StyleServices: TThemeServicesEx;
(******************* NOT CONVERTED
{ PaintControlBorder paints the themed border for WinControls only when they
have the WS_EX_CLIENTEDGE. }
procedure PaintControlBorder(Control: TWinControl);
{ DrawThemedBorder draws a teEditTextNormal element (border) to the DC. It uses
the Control's BoundsRect. DrawThemedBorder forces border painting. }
procedure DrawThemedBorder(Control: TControl);
{$ENDIF JVCLThemesEnabled}
**********************)
type
TJvThemeStyle = TControlStyle;
{
Instead of the ControlStyle property you should use the following functions:
ControlStyle := ControlStyle + [csXxx]; -> IncludeThemeStyle(Self, [csXxx]);
ControlStyle := ControlStyle - [csXxx]; -> ExcludeThemeStyle(Self, [csXxx]);
if csXxx in ControlStyle then -> if csXxx in GetThemeStyle(Self) then
}
procedure IncludeThemeStyle(Control: TControl; Style: TJvThemeStyle);
procedure ExcludeThemeStyle(Control: TControl; Style: TJvThemeStyle);
function GetThemeStyle(Control: TControl): TJvThemeStyle;
{ DrawThemedBackground fills R with Canvas.Brush.Color/Color. If the control uses
csParentBackground and the color is that of it's parent the Rect is not filled
because then it is done by the JvThemes/VCL7. }
procedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;
const R: TRect; NeedsParentBackground: Boolean = True); overload;
procedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;
const R: TRect; Color: TColor; NeedsParentBackground: Boolean = True); overload;
procedure DrawThemedBackground(Control: TControl; DC: HDC; const R: TRect;
Brush: HBRUSH; NeedsParentBackground: Boolean = True); overload;
(***************************** NOT CONVERTED ***
{ DrawThemesFrameControl draws a themed frame control when theming is enabled. }
function DrawThemedFrameControl(DC: HDC; const Rect: TRect; uType, uState: UINT): BOOL;
*)
{ PerformEraseBackground sends a WM_ERASEBKGND message to the Control's parent. }
procedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint); overload;
procedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint; const R: TRect); overload;
procedure PerformEraseBackground(Control: TControl; DC: HDC); overload;
procedure PerformEraseBackground(Control: TControl; DC: HDC; const R: TRect); overload;
(***************************** NOT CONVERTED ***
{ DrawThemedButtonFace draws a themed button when theming is enabled. }
function DrawThemedButtonFace(Control: TControl; Canvas: TCanvas; const Client: TRect;
BevelWidth: Integer; Style: TButtonStyle; IsRounded, IsDown,
IsFocused, IsHot: Boolean): TRect;
{ IsMouseOver returns True if the mouse is over the control. }
function IsMouseOver(Control: TControl): Boolean;
// ~COMPILER7_UP: These functions are helpers for Delphi 6 that doesn't have the csParentPackground flag.
{ GetParentBackground returns True if the Control has the csParentPackground
ControlStyle }
function GetParentBackground(Control: TWinControl): Boolean;
{ SetParentBackground sets the Control's csParentPackground ControlStyle }
procedure SetParentBackground(Control: TWinControl; Value: Boolean);
{ GetGlassPaintFlag returns True if csGlassPaint in ControlState }
function GetGlassPaintFlag(AControl: TControl): Boolean;
{ ControlInGlassPaint returns True if the Control is painted on a glass area }
function ControlInGlassPaint(AControl: TControl): Boolean;
{ DrawGlassableText paints text to a device context with support of PaintOnGlass }
procedure DrawGlassableText(DC: HDC; const Text: string; var TextRect: TRect; TextFlags: Cardinal;
PaintOnGlass: Boolean = False);
{ DrawGlassableImageList paint a transparent imagelist image to the canvas with
support of PaintOnGlass }
procedure DrawGlassableImageList(ImageList: HIMAGELIST; Index: Integer; Dest: HDC; X, Y: Integer;
Style: UINT; PaintOnGlass: Boolean = False);
******************)
implementation
(*
uses
{$IFNDEF COMPILER10_UP}
JclSysUtils,
{$ENDIF ~COMPILER10_UP}
JclSysInfo;
*)
type
TWinControlThemeInfo = class(TWinControl)
public
property Color;
end;
procedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;
const R: TRect; NeedsParentBackground: Boolean = True);
begin
DrawThemedBackground(Control, Canvas, R, Canvas.Brush.Color, NeedsParentBackground);
end;
procedure DrawThemedBackground(Control: TControl; Canvas: TCanvas;
const R: TRect; Color: TColor; NeedsParentBackground: Boolean = True);
var
Cl: TColor;
begin
{$IFDEF JVCLThemesEnabled}
if StyleServices.Enabled and
(Control.Parent <> nil) and
((Color = TWinControlThemeInfo(Control.Parent).Color) or
(ColorToRGB(Color) = ColorToRGB(TWinControlThemeInfo(Control.Parent).Color))) and
(not NeedsParentBackground or (csParentBackground in GetThemeStyle(Control))) then
begin
if Control is TWinControl then
begin
if TWinControl(Control).DoubleBuffered then
PerformEraseBackground(Control, Canvas.Handle, R)
else
StyleServices.DrawParentBackground(TWinControl(Control).Handle, Canvas.Handle, nil,
False, @R);
end
else
PerformEraseBackground(Control, Canvas.Handle, R)
end
else
{$ENDIF JVCLThemesEnabled}
begin
{$IFDEF JVCLStylesEnabled}
if StyleServices.Enabled and TStyleManager.IsCustomStyleActive then
Color := StyleServices.GetSystemColor(Color);
{$ENDIF JVCLStylesEnabled}
Cl := Canvas.Brush.Color;
if Cl <> Color then
Canvas.Brush.Color := Color;
Canvas.FillRect(R);
if Cl <> Canvas.Brush.Color then
Canvas.Brush.Color := Cl;
end;
end;
procedure DrawThemedBackground(Control: TControl; DC: HDC; const R: TRect;
Brush: HBRUSH; NeedsParentBackground: Boolean = True);
{$IFDEF JVCLThemesEnabled}
var
LogBrush: TLogBrush;
{$ENDIF JVCLThemesEnabled}
begin
{$IFDEF JVCLThemesEnabled}
GetObject(Brush, SizeOf(LogBrush), @LogBrush);
if StyleServices.Enabled and
(Control.Parent <> nil) and
(LogBrush.lbColor = Cardinal(ColorToRGB(TWinControlThemeInfo(Control.Parent).Color))) and
(not NeedsParentBackground or (csParentBackground in GetThemeStyle(Control))) then
begin
if Control is TWinControl then
begin
if TWinControl(Control).DoubleBuffered then
PerformEraseBackground(Control, DC, R)
else
StyleServices.DrawParentBackground(TWinControl(Control).Handle, DC, nil, False, @R);
end
else
PerformEraseBackground(Control, DC, R)
end
else
{$ENDIF JVCLThemesEnabled}
FillRect(DC, R, Brush);
end;
(************************ NOT CONVERTED ***
function DrawThemedFrameControl(DC: HDC; const Rect: TRect; uType, uState: UINT): BOOL;
{$IFDEF JVCLThemesEnabled}
const
Mask = $00FF;
var
Btn: TThemedButton;
ComboBox: TThemedComboBox;
ScrollBar: TThemedScrollBar;
R: TRect;
Details: TThemedElementDetails;
{$ENDIF JVCLThemesEnabled}
begin
Result := False;
{$IFDEF JVCLThemesEnabled}
if StyleServices.Enabled then
begin
R := Rect;
case uType of
DFC_BUTTON:
case uState and Mask of
DFCS_BUTTONPUSH:
begin
if uState and (DFCS_TRANSPARENT or DFCS_FLAT) = 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
Btn := tbPushButtonDisabled
else
if uState and DFCS_PUSHED <> 0 then
Btn := tbPushButtonPressed
else
if uState and DFCS_HOT <> 0 then
Btn := tbPushButtonHot
else
if uState and DFCS_MONO <> 0 then
Btn := tbPushButtonDefaulted
else
Btn := tbPushButtonNormal;
Details := StyleServices.GetElementDetails(Btn);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
end;
DFCS_BUTTONCHECK:
begin
if uState and DFCS_CHECKED <> 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
Btn := tbCheckBoxCheckedDisabled
else
if uState and DFCS_PUSHED <> 0 then
Btn := tbCheckBoxCheckedPressed
else
if uState and DFCS_HOT <> 0 then
Btn := tbCheckBoxCheckedHot
else
Btn := tbCheckBoxCheckedNormal;
end
else
if uState and DFCS_MONO <> 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
Btn := tbCheckBoxMixedDisabled
else
if uState and DFCS_PUSHED <> 0 then
Btn := tbCheckBoxMixedPressed
else
if uState and DFCS_HOT <> 0 then
Btn := tbCheckBoxMixedHot
else
Btn := tbCheckBoxMixedNormal;
end
else
begin
if uState and DFCS_INACTIVE <> 0 then
Btn := tbCheckBoxUncheckedDisabled
else
if uState and DFCS_PUSHED <> 0 then
Btn := tbCheckBoxUncheckedPressed
else
if uState and DFCS_HOT <> 0 then
Btn := tbCheckBoxUncheckedHot
else
Btn := tbCheckBoxUncheckedNormal;
end;
Details := StyleServices.GetElementDetails(Btn);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
DFCS_BUTTONRADIO:
begin
if uState and DFCS_CHECKED <> 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
Btn := tbRadioButtonCheckedDisabled
else
if uState and DFCS_PUSHED <> 0 then
Btn := tbRadioButtonCheckedPressed
else
if uState and DFCS_HOT <> 0 then
Btn := tbRadioButtonCheckedHot
else
Btn := tbRadioButtonCheckedNormal;
end
else
begin
if uState and DFCS_INACTIVE <> 0 then
Btn := tbRadioButtonUncheckedDisabled
else
if uState and DFCS_PUSHED <> 0 then
Btn := tbRadioButtonUncheckedPressed
else
if uState and DFCS_HOT <> 0 then
Btn := tbRadioButtonUncheckedHot
else
Btn := tbRadioButtonUncheckedNormal;
end;
Details := StyleServices.GetElementDetails(Btn);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
end;
DFC_SCROLL:
begin
case uState and Mask of
DFCS_SCROLLCOMBOBOX:
begin
if uState and DFCS_INACTIVE <> 0 then
ComboBox := tcDropDownButtonDisabled
else
if uState and DFCS_PUSHED <> 0 then
ComboBox := tcDropDownButtonPressed
else
if uState and DFCS_HOT <> 0 then
ComboBox := tcDropDownButtonHot
else
ComboBox := tcDropDownButtonNormal;
Details := StyleServices.GetElementDetails(ComboBox);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
DFCS_SCROLLUP:
if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
ScrollBar := tsArrowBtnUpDisabled
else
if uState and DFCS_PUSHED <> 0 then
ScrollBar := tsArrowBtnUpPressed
else
if uState and DFCS_HOT <> 0 then
ScrollBar := tsArrowBtnUpHot
else
ScrollBar := tsArrowBtnUpNormal;
Details := StyleServices.GetElementDetails(ScrollBar);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
DFCS_SCROLLDOWN:
if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
ScrollBar := tsArrowBtnDownDisabled
else
if uState and DFCS_PUSHED <> 0 then
ScrollBar := tsArrowBtnDownPressed
else
if uState and DFCS_HOT <> 0 then
ScrollBar := tsArrowBtnDownHot
else
ScrollBar := tsArrowBtnDownNormal;
Details := StyleServices.GetElementDetails(ScrollBar);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
DFCS_SCROLLLEFT:
if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
ScrollBar := tsArrowBtnLeftDisabled
else
if uState and DFCS_PUSHED <> 0 then
ScrollBar := tsArrowBtnLeftPressed
else
if uState and DFCS_HOT <> 0 then
ScrollBar := tsArrowBtnLeftHot
else
ScrollBar := tsArrowBtnLeftNormal;
Details := StyleServices.GetElementDetails(ScrollBar);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
DFCS_SCROLLRIGHT:
if uState and (DFCS_TRANSPARENT {or DFCS_FLAT}) = 0 then
begin
if uState and DFCS_INACTIVE <> 0 then
ScrollBar := tsArrowBtnRightDisabled
else
if uState and DFCS_PUSHED <> 0 then
ScrollBar := tsArrowBtnRightPressed
else
if uState and DFCS_HOT <> 0 then
ScrollBar := tsArrowBtnRightHot
else
ScrollBar := tsArrowBtnRightNormal;
Details := StyleServices.GetElementDetails(ScrollBar);
StyleServices.DrawElement(DC, Details, R);
Result := True;
end;
end;
end;
end;
end;
{$ENDIF JVCLThemesEnabled}
if not Result then
Result := DrawFrameControl(DC, Rect, uType, uState);
end;
*)
function IsInvalidRect(const R: TRect): Boolean; {$IFDEF SUPPORTS_INLINE} inline; {$ENDIF}
begin
Result := (R.Left = MaxInt) and (R.Top = MaxInt) and (R.Right = MaxInt) and (R.Bottom = MaxInt);
end;
procedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint);
begin
PerformEraseBackground(Control, DC, Offset, Rect(MaxInt, MaxInt, MaxInt, MaxInt));
end;
procedure PerformEraseBackground(Control: TControl; DC: HDC; Offset: TPoint; const R: TRect);
var
WindowOrg: TPoint = (X:0; Y:0);
OrgRgn, Rgn: THandle;
{$IFDEF COMPILER16_UP}
OldPen: HPEN;
OldBrush: HBRUSH;
OldFont: HFONT;
OldTextColor: TColorRef;
OldBkMode: Integer;
{$ENDIF COMPILER16_UP}
begin
if Control.Parent <> nil then
begin
if (Offset.X <> 0) and (Offset.Y <> 0) then
begin
GetWindowOrgEx(DC, WindowOrg);
if Control is TGraphicControl then
SetWindowOrgEx(DC, -Offset.X, -Offset.Y, nil)
else
SetWindowOrgEx(DC, WindowOrg.X + Offset.X, WindowOrg.Y + Offset.Y, nil);
end;
OrgRgn := 0;
if not IsInvalidRect(R) then
begin
OrgRgn := CreateRectRgn(0, 0, 1, 1);
if GetClipRgn(DC, OrgRgn) = 0 then
begin
DeleteObject(OrgRgn);
OrgRgn := 0;
end;
Rgn := CreateRectRgnIndirect(R);
SelectClipRgn(DC, Rgn);
DeleteObject(Rgn);
end;
try
{$IFDEF COMPILER16_UP}
// Delphi XE2's Style-Engine has a bug in the TStyleHook.WMEraseBkgnd that replaces the
// selected GDI objects with the TCanvas default objects ("System" font, ...).
// We need to repair the damage in order to have the same behavior of the native theming API.
// General rule for WM_ERASEBKGND: Return the DC in the state in that it was when the function
// was called.
OldPen := 0;
OldBrush := 0;
OldFont := 0;
OldTextColor := 0;
OldBkMode := 0;
if StyleServices.Enabled and not StyleServices.IsSystemStyle then
begin
OldPen := GetCurrentObject(DC, OBJ_PEN);
OldBrush := GetCurrentObject(DC, OBJ_BRUSH);
OldFont := GetCurrentObject(DC, OBJ_FONT);
OldTextColor := GetTextColor(DC);
OldBkMode := GetBkMode(DC);
end;
{$ENDIF COMPILER16_UP}
Control.Parent.Perform(LM_ERASEBKGND, DC, DC); // force redraw
{$IFDEF COMPILER16_UP}
if StyleServices.Enabled and not StyleServices.IsSystemStyle then
begin
if GetCurrentObject(DC, OBJ_PEN) <> OldPen then
SelectObject(DC, OldPen);
if GetCurrentObject(DC, OBJ_BRUSH) <> OldBrush then
SelectObject(DC, OldBrush);
if GetCurrentObject(DC, OBJ_FONT) <> OldFont then
SelectObject(DC, OldFont);
if GetTextColor(DC) <> OldTextColor then
SetTextColor(DC, OldTextColor);
if GetBkMode(DC) <> OldBkMode then
SetBkMode(DC, OldBkMode);
end;
{$ENDIF COMPILER16_UP}
finally
if (Offset.X <> 0) and (Offset.Y <> 0) then
SetWindowOrgEx(DC, WindowOrg.X, WindowOrg.Y, nil);
if OrgRgn <> 0 then
begin
SelectClipRgn(DC, OrgRgn);
DeleteObject(OrgRgn);
end;
end;
end;
end;
procedure PerformEraseBackground(Control: TControl; DC: HDC);
begin
PerformEraseBackground(Control, DC, Point(Control.Left, Control.Top));
end;
procedure PerformEraseBackground(Control: TControl; DC: HDC; const R: TRect);
begin
PerformEraseBackground(Control, DC, Point(Control.Left, Control.Top), R);
end;
(***************************** NOT CONVERTED ***
function DrawThemedButtonFace(Control: TControl; Canvas: TCanvas;
const Client: TRect; BevelWidth: Integer; Style: TButtonStyle;
IsRounded, IsDown, IsFocused, IsHot: Boolean): TRect;
{$IFDEF JVCLThemesEnabled}
var
Btn: TThemedButton;
Details: TThemedElementDetails;
{$ENDIF JVCLThemesEnabled}
begin
{$IFDEF JVCLThemesEnabled}
if (Style <> bsWin31) and StyleServices.Enabled then
begin
Result := Client;
if IsDown then
Btn := tbPushButtonPressed
else
if IsFocused then
Btn := tbPushButtonDefaulted
else
if IsHot then
Btn := tbPushButtonHot
else
Btn := tbPushButtonNormal;
Details := StyleServices.GetElementDetails(Btn);
StyleServices.DrawElement(Canvas.Handle, Details, Result);
StyleServices.GetElementContentRect(Canvas.Handle, Details, Client, Result);
if IsFocused then
DrawFocusRect(Canvas.Handle, Result);
InflateRect(Result, -BevelWidth, -BevelWidth);
end
else
{$ENDIF JVCLThemesEnabled}
Result := DrawButtonFace(Canvas, Client, BevelWidth, Style, IsRounded, IsDown, IsFocused);
end;
function IsMouseOver(Control: TControl): Boolean;
var
Pt: TPoint;
begin
Pt := Control.ScreenToClient(Mouse.CursorPos);
Result := PtInRect(Control.ClientRect, Pt);
end;
function GetParentBackground(Control: TWinControl): Boolean;
begin
Result := csParentBackground in GetThemeStyle(Control);
end;
procedure SetParentBackground(Control: TWinControl; Value: Boolean);
begin
if Value <> GetParentBackground(Control) then
begin
if Value then
IncludeThemeStyle(Control, [csParentBackground])
else
ExcludeThemeStyle(Control, [csParentBackground]);
Control.Invalidate;
end;
end;
function GetGlassPaintFlag(AControl: TControl): Boolean;
{$IFDEF COMPILER11}
var
Form: TCustomForm;
{$ENDIF COMPILER11}
begin
{$IFDEF COMPILER12_UP}
Result := csGlassPaint in AControl.ControlState;
{$ELSE}
Result := False;
{$IFDEF COMPILER11}
Form := GetParentForm(AControl);
if (Form <> nil) and Form.GlassFrame.Enabled then
Result := Form.GlassFrame.IntersectsControl(AControl);
{$ENDIF COMPILER11}
{$ENDIF COMPILER12_UP}
end;
function ControlInGlassPaint(AControl: TControl): Boolean;
{$IFDEF COMPILER11_UP}
var
Parent: TWinControl;
{$ENDIF COMPILER11_UP}
begin
{$IFDEF COMPILER11_UP}
Result := GetGlassPaintFlag(AControl);
if Result then
begin
Parent := AControl.Parent;
while (Parent <> nil) and not Parent.DoubleBuffered and not (Parent is TCustomForm) do
Parent := Parent.Parent;
Result := (Parent = nil) or not Parent.DoubleBuffered or (Parent is TCustomForm);
end;
{$ELSE}
Result := False;
{$ENDIF COMPILER11_UP}
end;
procedure DrawGlassableText(DC: HDC; const Text: string; var TextRect: TRect; TextFlags: Cardinal;
PaintOnGlass: Boolean = False);
{$IFDEF COMPILER11_UP}
var
Options: TDTTOpts;
{$IFDEF COMPILER11}
S: WideString;
{$ENDIF COMPILER11}
{$ENDIF COMPILER11_UP}
begin
{$IFDEF COMPILER11_UP}
if StyleServices.Enabled and JclCheckWinVersion(6, 0) then
begin
FillChar(Options, SizeOf(Options), 0);
Options.dwSize := SizeOf(Options);
if TextFlags and DT_CALCRECT <> 0 then
Options.dwFlags := Options.dwFlags or DTT_CALCRECT;
if PaintOnGlass then
Options.dwFlags := Options.dwFlags or DTT_COMPOSITED;
Options.dwFlags := Options.dwFlags or DTT_TEXTCOLOR;
Options.crText := GetTextColor(DC);
{$IFDEF COMPILER16_UP}
if not StyleServices.IsSystemStyle then
begin
// The Style engine doesn't have DrawThemeTextEx support
{$WARNINGS OFF} // ignore "deprecated" warning
StyleServices.DrawText(DC, StyleServices.GetElementDetails(tbPushButtonNormal), Text, TextRect, TextFlags, 0);
{$WARNINGS ON}
Exit;
end
else
{$ENDIF}
begin
{$IFDEF COMPILER12_UP}
with ThemeServices do
if DrawThemeTextEx(Theme[teToolBar], DC, TP_BUTTON, TS_NORMAL, PWideChar(Text), Length(Text),
TextFlags, TextRect, Options) <> E_NOTIMPL then
Exit;
{$ELSE}
S := Text;
with ThemeServices do
if DrawThemeTextEx(Theme[teToolBar], DC, TP_BUTTON, TS_NORMAL, PWideChar(S), Length(S),
TextFlags, @TextRect, Options) <> E_NOTIMPL then
Exit;
{$ENDIF COMPILER12_UP}
end;
end;
{$ENDIF COMPILER11_UP}
Windows.DrawText(DC, PChar(Text), Length(Text), TextRect, TextFlags);
end;
procedure DrawGlassableImageList(ImageList: HIMAGELIST; Index: Integer; Dest: HDC; X, Y: Integer;
Style: UINT; PaintOnGlass: Boolean = False);
{$IFDEF COMPILER11_UP}
var
PaintBuffer: HPAINTBUFFER;
R: TRect;
MemDC, MaskDC: HDC;
CX, CY, XX, YY: Integer;
MaskBmp: TBitmap;
{$ENDIF COMPILER11_UP}
begin
{$IFDEF COMPILER11_UP}
if PaintOnGlass and JclCheckWinVersion(6, 0) then
begin
{ TODO : Not working correctly on a JvSpeedButton. But it works if used direcly on
a sheet of glass. Some optimizations could be done. }
ImageList_GetIconSize(ImageList, CX, CY);
R := Rect(X, Y, X + CX, Y + CY);
PaintBuffer := BeginBufferedPaint(Dest, R, BPBF_TOPDOWNDIB, nil, MemDC);
try
ImageList_Draw(ImageList, Index, MemDC, X, Y, Style);
BufferedPaintMakeOpaque(PaintBuffer, @R);
MaskBmp := TBitmap.Create;
try
MaskBmp.Width := CX;
MaskBmp.Height := CY;
MaskDC := MaskBmp.Canvas.Handle;
ImageList_Draw(ImageList, Index, MaskDC, 0, 0, ILD_MASK);
for YY := 0 to CY - 1 do
for XX := 0 to CX - 1 do
if GetPixel(MaskDC, XX, YY) <> 0 then
begin
R := Rect(X + XX, Y + YY, X + XX + 1, Y + YY + 1);
BufferedPaintSetAlpha(PaintBuffer, @R, 0);
//SetPixel(MemDC, X + XX, Y + YY, GetPixel(MemDC, X + XX, Y + YY) and $00FFFFFF);
end;
finally
MaskBmp.Free;
end;
finally
EndBufferedPaint(PaintBuffer, True);
end;
end
else
{$ENDIF COMPILER11_UP}
ImageList_Draw(ImageList, Index, Dest, X, Y, Style);
end;
*******************)
(************************ NOT CONVERTED ***
{$IFDEF JVCLThemesEnabled}
{$IFNDEF COMPILER7_UP}
procedure TThemeServicesEx.ApplyThemeChange;
begin
StyleServices.UpdateThemes;
StyleServices.DoOnThemeChange;
end;
{$ENDIF ~COMPILER7_UP}
{$IFNDEF COMPILER16_UP}
function TThemeServicesEx.GetElementContentRect(DC: HDC; Details: TThemedElementDetails;
const BoundingRect: TRect; out AContentRect: TRect): Boolean;
begin
AContentRect := ContentRect(DC, Details, BoundingRect);
Result := True;
end;
function TThemeServicesEx.DoGetElementSize(DC: HDC; Details: TThemedElementDetails; Rect: PRect;
ElementSize: TElementSize; out Size: TSize): Boolean;
const
ElementSizes: array[TElementSize] of TThemeSize = (TS_MIN, TS_TRUE, TS_DRAW);
begin
Result := GetThemePartSize(Theme[Details.Element], DC, Details.Part, Details.State, Rect,
ElementSizes[ElementSize], Size) = S_OK;
end;
function TThemeServicesEx.GetElementSize(DC: HDC; Details: TThemedElementDetails; ElementSize: TElementSize;
out Size: TSize): Boolean;
begin
Result := DoGetElementSize(DC, Details, nil, ElementSize, Size);
end;
function TThemeServicesEx.GetElementSize(DC: HDC; Details: TThemedElementDetails; const Rect: TRect;
ElementSize: TElementSize; out Size: TSize): Boolean;
begin
Result := DoGetElementSize(DC, Details, @Rect, ElementSize, Size);
end;
function TThemeServicesEx.GetSystemColor(Color: TColor): TColor;
begin
Result := Color;
end;
**********************)
function TThemeServicesEx.IsSystemStyle: Boolean;
begin
Result := True;
end;
function TThemeServicesEx.Enabled: Boolean;
begin
Result := ThemesEnabled;
end;
function TThemeServicesEx.Available: Boolean;
begin
Result := ThemesAvailable;
end;
(******************************
{$ENDIF ~COMPILER16_UP}
*******************)
function ThemeServices: TThemeServicesEx;
begin
Result := TThemeServicesEx(
{$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.{$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP});
end;
function StyleServices: TThemeServicesEx;
begin
Result := TThemeServicesEx(
{$IFDEF COMPILER7_UP}Themes{$ELSE}ThemeSrv{$ENDIF}.{$IFDEF RTL230_UP}StyleServices{$ELSE}ThemeServices{$ENDIF RTL230_UP});
end;
(************************ NOT CONVERTED ***
procedure PaintControlBorder(Control: TWinControl);
begin
StyleServices.PaintBorder(Control, False)
end;
procedure DrawThemedBorder(Control: TControl);
var
Details: TThemedElementDetails;
DrawRect: TRect;
DC: HDC;
Handle: THandle;
begin
if Control is TWinControl then
begin
Handle := TWinControl(Control).Handle;
DC := GetWindowDC(Handle);
GetWindowRect(Handle, DrawRect);
OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);
end
else
begin
if Control.Parent = nil then
Exit;
Handle := Control.Parent.Handle;
DC := GetDC(Handle);
DrawRect := Control.BoundsRect;
end;
ExcludeClipRect(DC, DrawRect.Left + 2, DrawRect.Top + 2, DrawRect.Right - 2, DrawRect.Bottom - 2);
Details := StyleServices.GetElementDetails(teEditTextNormal);
StyleServices.DrawElement(DC, Details, DrawRect);
ReleaseDC(Handle, DC);
end;
***************************)
type
TControlAccessProtected = class(TControl);
procedure IncludeThemeStyle(Control: TControl; Style: TJvThemeStyle);
begin
with TControlAccessProtected(Control) do
ControlStyle := ControlStyle + (Style * [csNeedsBorderPaint, csParentBackground]);
end;
procedure ExcludeThemeStyle(Control: TControl; Style: TJvThemeStyle);
begin
with TControlAccessProtected(Control) do
ControlStyle := ControlStyle - (Style * [csNeedsBorderPaint, csParentBackground]);
end;
function GetThemeStyle(Control: TControl): TJvThemeStyle;
begin
with TControlAccessProtected(Control) do
Result := ControlStyle * [csNeedsBorderPaint, csParentBackground];
end;
(********************* NOT CONVERTED ***
{$IFDEF JVCLThemesEnabled}
{$IFNDEF COMPILER10_UP}
type
PPointer = ^Pointer;
var
OrgWinControlWMPrintClient: procedure(Instance: TObject; var Msg: TMessage);
procedure FixedWMPrintClient(Instance: TObject; var Msg: TMessage);
var
IdSave: Integer;
begin
if Msg.Msg = WM_PRINTCLIENT then
begin
IdSave := SaveDC(HDC(Msg.WParam));
try
OrgWinControlWMPrintClient(Instance, Msg);
finally
RestoreDC(HDC(Msg.WParam), IdSave);
end;
end
else
OrgWinControlWMPrintClient(Instance, Msg);
end;
function FindWMPrintClient: PPointer;
var
IdxList: PDynamicIndexList;
I: Integer;
begin
IdxList := GetDynamicIndexList(TWinControl);
for I := 0 to GetDynamicMethodCount(TWinControl) - 1 do
if IdxList[I] = WM_PRINTCLIENT then
begin
Result := @(GetDynamicAddressList(TWinControl)[I]);
Exit;
end;
Result := nil;
end;
procedure InitializeWMPrintClientFix;
var
NewProc: Pointer;
Proc: PPointer;
OldProtect, Dummy: Cardinal;
begin
Proc := FindWMPrintClient();
if Proc <> nil then
begin
OrgWinControlWMPrintClient := Proc^;
NewProc := @FixedWMPrintClient;
if VirtualProtect(Proc, SizeOf(NewProc), PAGE_EXECUTE_READWRITE, OldProtect) then
try
Proc^ := NewProc;
finally
VirtualProtect(Proc, SizeOf(NewProc), OldProtect, Dummy);
end;
end;
end;
procedure FinalizeWMPrintClientFix;
var
NewProc: Pointer;
Proc: PPointer;
OldProtect, Dummy: Cardinal;
begin
Proc := FindWMPrintClient;
if Proc <> nil then
begin
NewProc := @OrgWinControlWMPrintClient;
if VirtualProtect(Proc, SizeOf(NewProc), PAGE_EXECUTE_READWRITE, OldProtect) then
try
Proc^ := NewProc;
finally
VirtualProtect(Proc, SizeOf(NewProc), OldProtect, Dummy);
end;
end;
end;
{$ENDIF ~COMPILER10_UP}
{$ENDIF JVCLThemesEnabled}
************)
initialization
(************** NOT CONVERTED ***
{$IFDEF JVCLThemesEnabled}
{$IFNDEF COMPILER10_UP}
InitializeWMPrintClientFix;
{$ENDIF ~COMPILER10_UP}
{$ENDIF JVCLThemesEnabled}
**********)
finalization
(*************** NOT CONVERTED ***
{$IFDEF JVCLThemesEnabled}
{$IFNDEF COMPILER10_UP}
FinalizeWMPrintClientFix;
{$ENDIF ~COMPILER10_UP}
{$ENDIF JVCLThemesEnabled}
*************)
end.
Reference in New Issue View Git Blame Copy Permalink