paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-27 11:00:37 +02:00
Code Issues Packages Projects Releases Wiki Activity

fix winxp theming for tabcontrols (shaded background)

Browse Source 
git-svn-id: trunk@6167 -
This commit is contained in:
micha 2004-10-27 20:58:58 +00:00
parent 540fe4285a
commit 84c8159e94
6 changed files with 239 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

229
lcl/interfaces/win32/win32callback.inc
View File

@ -65,7 +65,7 @@ Begin
End;
{------------------------------------------------------------------------------
Function: CallDefaultWndProc
Function: CallDefaultWindowProc
Params: Window - The window that receives a message
Msg - The message received
WParam - Word parameter
@ -87,6 +87,22 @@ begin
Result := Windows.CallWindowProc(Windows.WNDPROC(PrevWndProc), Window, Msg, WParam, LParam);
end;
type
TEraseBkgndCommand = (ecDefault, ecPaint, ecNoMsg);
const
EraseBkgndStackMask = $3;
EraseBkgndStackShift = 2;
var
EraseBkgndStack: dword;
{$ifdef MSG_DEBUG}
MessageStackDepth: string;
{$endif}
procedure PushEraseBkgndCommand(Command: TEraseBkgndCommand);
begin
EraseBkgndStack := (EraseBkgndStack shl EraseBkgndStackShift) or dword(Ord(Command));
end;
{------------------------------------------------------------------------------
Function: WindowProc
Params: Window - The window that receives a message
@ -98,7 +114,13 @@ end;
Handles the messages sent to the specified window, in parameter Window, by
Windows or other applications
------------------------------------------------------------------------------}
Function WindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
Function
{$ifdef MSG_DEBUG}
RealWindowProc
{$else}
WindowProc
{$endif}
(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult; stdcall;
Var
LMessage: TLMessage;
@ -114,6 +136,8 @@ Var
OverlayWindow: HWND;
TargetWindow: HWND;
DlgCode, CharCode: dword;
eraseBkgndCommand: TEraseBkgndCommand;
winClassName: array[0..19] of char;
LMInsertText: TLMInsertText; // used by CB_INSERTSTRING, LB_INSERTSTRING
LMScroll: TLMScroll; // used by WM_HSCROLL
@ -178,16 +202,64 @@ Var
AWinControl: TWinControl;
PaintMsg: TLMPaint;
ORect: TRect;
parLeft, parTop: integer;
useDoubleBuffer: boolean;
parentPaint: boolean;
hasTabParent: boolean;
isTabPage: boolean;
isNotebook: boolean;
begin
// note: ignores the received DC
// do not use default deliver message
if (OwnerObject=nil) or (not (OwnerObject is TWinControl)) then
exit;
if not (OwnerObject is TWinControl) then
begin
OwnerObject := TObject(Windows.GetProp(Window, 'PWinControl'));
if not (OwnerObject is TWinControl) then
exit;
end;
// create a paint message
WinProcess := false;
AWinControl := TWinControl(OwnerObject);
if AWinControl.DoubleBuffered then
GetClassName(Window, winClassName, 20);
hasTabParent := Windows.GetProp(Window, 'TabPageParent') <> 0;
isTabPage := (Windows.GetProp(Window, 'TabPage') <> 0);
isNotebook := TWin32WidgetSet(InterfaceObject).ThemesActive and
CompareMem(@winClassName, @TabControlClsName, High(TabControlClsName)+1);
parentPaint := isTabPage or (hasTabParent and (WParam <> 0));
// if painting background of some control for tabpage, don't handle erase background
// in parent of tabpage
if isTabPage then
begin
{$ifdef MSG_DEBUG}
writeln(MessageStackDepth, ' *forcing next WM_ERASEBKGND to disable message');
{$endif}
PushEraseBkgndCommand(ecNoMsg);
end;
// if this is a groupbox in a tab, then the next erasebackground is for
// drawing the background of the caption, send paint message then
if hasTabParent and ((GetWindowLong(Window, GWL_STYLE) and BS_GROUPBOX) = BS_GROUPBOX)
and (WParam = 0) and CompareMem(@winClassName, @ButtonClsName, High(ButtonClsName)+1) then
begin
{$ifdef MSG_DEBUG}
writeln(MessageStackDepth, ' *forcing next WM_ERASEBKGND to send paint message');
{$endif}
PushEraseBkgndCommand(ecPaint);
end;
// if need to start paint, paint by calling parent, and we have no
// controls, is a native control, use default win32 painting to avoid flicker
if hasTabParent and (WParam = 0) and (AWinControl.ControlCount = 0) and
not CompareMem(@winClassName, @ClsName, High(ClsName)+1) then
begin
// optimization: no child controls -> default painting
exit;
end;
// check if double buffering is requested
useDoubleBuffer := (WParam = 0) and AWinControl.DoubleBuffered;
if useDoubleBuffer then
begin
DC := Windows.GetDC(0);
GetWindowSize(Window, MemWidth, MemHeight);
@ -198,27 +270,47 @@ Var
PaintMsg.DC := MemDC;
end;
if not GetLCLClientBoundsOffset(AWinControl.Handle, ORect) then
begin
ORect.Left := 0;
ORect.Top := 0;
{ we don't use ORect.Right and ORect.Bottom, initialize here if needed }
end;
WinProcess := false;
try
DC := Windows.BeginPaint(Window, @PS);
if WParam = 0 then
begin
DC := Windows.BeginPaint(Window, @PS);
end else begin
DC := WParam;
end;
if parentPaint then
GetWin32ControlPos(Window, GetParent(Window), parLeft, parTop);
if not GetLCLClientBoundsOffset(AWinControl, ORect) then
begin
ORect.Left := 0;
ORect.Top := 0;
{ we don't use ORect.Right and ORect.Bottom, initialize here if needed }
end;
PaintMsg.Msg := LM_PAINT;
PaintMsg.PaintStruct := @PS;
if not AWinControl.DoubleBuffered then
if not useDoubleBuffer then
PaintMsg.DC := DC;
AWinControl.EraseBackground(PaintMsg.DC);
MoveWindowOrgEx(PaintMsg.DC, ORect.Left, ORect.Top);
DeliverMessage(OwnerObject, PaintMsg);
MoveWindowOrgEx(PaintMsg.DC, -ORect.Left, -ORect.Top);
if AWinControl.DoubleBuffered then
if not hasTabParent and not isNotebook then
AWinControl.EraseBackground(PaintMsg.DC);
if parentPaint then
begin
// tabpage parent and got a dc to draw in, divert paint to parent
MoveWindowOrgEx(PaintMsg.DC, -parLeft, -parTop);
SendMessage(GetParent(Window), WM_PAINT, PaintMsg.DC, 0);
MoveWindowOrgEx(PaintMsg.DC, parLeft, parTop);
end;
if (WParam = 0) or not hasTabParent then
begin
MoveWindowOrgEx(PaintMsg.DC, ORect.Left, ORect.Top);
DeliverMessage(OwnerObject, PaintMsg);
MoveWindowOrgEx(PaintMsg.DC, -ORect.Left, -ORect.Top);
end;
if useDoubleBuffer then
Windows.BitBlt(DC, 0, 0, MemWidth, MemHeight, MemDC, 0, 0, SRCCOPY);
Windows.EndPaint(Window, @PS);
if WParam = 0 then
Windows.EndPaint(Window, @PS);
finally
if AWinControl.DoubleBuffered then
if useDoubleBuffer then
begin
SelectObject(MemDC, OldBitmap);
// for debugging purposes: copy rendered bitmap to clipboard
@ -439,19 +531,41 @@ Begin
End;
}
WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
Begin
MsgObject := TObject(GetProp(LParam, 'Wincontrol'));
if MsgObject = nil then
MsgObject := TObject(GetProp(LParam, 'AWincontrol'));
if MsgObject is TWinControl then
begin
// only static and button controls have transparent parts
// others need to erased with their window color
if ((Msg <> WM_CTLCOLORSTATIC) and (Msg <> WM_CTLCOLORBTN))
or (Windows.GetProp(LParam, 'TabPageParent') = 0) then
begin
Windows.SetTextColor(HDC(WParam), Windows.COLORREF(ColorToRGB(TWinControl(MsgObject).Font.Color)));
Windows.SetBkColor(HDC(WParam), Windows.COLORREF(ColorToRGB(TWinControl(MsgObject).Brush.Color)));
LMessage.Result := LResult(TWinControl(MsgObject).Brush.Handle);
// Override default handling
MsgObject := TObject(GetProp(LParam, 'Wincontrol'));
if MsgObject = nil then
MsgObject := TObject(GetProp(LParam, 'AWincontrol'));
if MsgObject is TWinControl then
begin
Windows.SetTextColor(HDC(WParam), Windows.COLORREF(ColorToRGB(TWinControl(MsgObject).Font.Color)));
Windows.SetBkColor(HDC(WParam), Windows.COLORREF(ColorToRGB(TWinControl(MsgObject).Brush.Color)));
LMessage.Result := LResult(TWinControl(MsgObject).Brush.Handle);
// Override default handling
WinProcess := false;
end;
end else begin
// comboboxes send WM_CTLCOLORSTATIC to their parent, but:
// 1) they are opaque, so don't need transparent background
// 2) we will overwrite combobox control, erasing the image!
GetClassName(LParam, winClassName, 10);
if not CompareMem(@winClassName, @ComboboxClsName, High(ComboBoxClsName)+1) then
begin
// need to draw transparently, draw background
GetWin32ControlPos(LParam, Window, P.X, P.Y);
MoveWindowOrgEx(WParam, -P.X, -P.Y);
SendMessage(Window, WM_PAINT, WParam, 0);
MoveWindowOrgEx(WParam, P.X, P.Y);
end;
LMessage.Result := GetStockObject(HOLLOW_BRUSH);
SetBkMode(WParam, TRANSPARENT);
WinProcess := false;
end;
End;
end;
WM_COPY:
Begin
LMessage.Msg := LM_COPYTOCLIP;
@ -534,14 +648,24 @@ Begin
End;
WM_ERASEBKGND:
Begin
LMessage.Msg := LM_ERASEBKGND;
LMessage.WParam := WParam;
LMessage.LParam := LParam;
eraseBkgndCommand := TEraseBkgndCommand(EraseBkgndStack and EraseBkgndStackMask);
EraseBkgndStack := EraseBkgndStack shr EraseBkgndStackShift;
if (eraseBkgndCommand <> ecNoMsg) and
(Windows.GetProp(Window, 'TabPageParent') = 0) then
begin
LMessage.Msg := LM_ERASEBKGND;
LMessage.WParam := WParam;
LMessage.LParam := LParam;
end else begin
if eraseBkgndCommand = ecPaint then
SendPaintMessage;
LMessage.Result := 1;
end;
WinProcess := false;
End;
WM_GETDLGCODE:
Begin
Result := DLGC_WANTALLKEYS;
LMessage.Result := DLGC_WANTALLKEYS;
WinProcess := false;
End;
WM_KEYDOWN:
@ -800,7 +924,7 @@ Begin
XPos := SmallInt(Lo(LParam));
YPos := SmallInt(Hi(LParam));
Keys := WParam;
LMMouse.Result := 0;
Result := 0;
End;
End;
WM_SETCURSOR:
@ -1020,21 +1144,6 @@ Begin
DeliverMessage(OwnerObject, PLMsg^);
case Msg of
WM_ERASEBKGND:
begin
// Groupbox (which is a button) doesn't erase it's background properly
// it's needed for winxp themes where controls send the WM_ERASEBKGND
// message to their parent to clear their background and then draw
// transparently
if (LMessage.Result = 0) and (TheWinControl <> nil) and
(TheWinControl.FCompStyle = csGroupBox) then
begin
TheWinControl.EraseBackground(WParam)
end else begin
WinProcess := true;
end;
end;
WM_SETCURSOR:
begin
if LMessage.Result = 0 then
@ -1110,6 +1219,21 @@ Begin
Assert(False, 'Trace:WindowProc - Exit');
End;
{$ifdef MSG_DEBUG}
function WindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult; stdcall;
begin
writeln(MessageStackDepth, 'WindowProc called for window=', window,' msg=', msg,' wparam=', wparam, ' lparam=',lparam);
MessageStackDepth := MessageStackDepth + ' ';
Result := RealWindowProc(Window, Msg, WParam, LParam);
setlength(MessageStackDepth, length(MessageStackDepth)-1);
end;
{$endif}
{------------------------------------------------------------------------------
Function: OverlayWindowProc
Params: Window - The window that receives a message
@ -1278,6 +1402,9 @@ end;
{
$Log$
Revision 1.145 2004/10/27 20:58:58 micha
fix winxp theming for tabcontrols (shaded background)
Revision 1.144 2004/10/17 14:53:48 micha
use font/brush of "parent", if this is a buddy window

18
lcl/interfaces/win32/win32int.pp
View File

@ -31,6 +31,10 @@ Interface
{$ASSERTIONS ON}
{$ENDIF}
// defining the following will print all messages as they are being handled
// valuable for investigation of message trees / interrelations
{ $define MSG_DEBUG}
{
When editing this unit list, be sure to keep Windows listed first to ensure
successful compilation.
@ -181,7 +185,10 @@ Type
const
BOOL_RESULT: Array[Boolean] Of String = ('False', 'True');
ClsName : array[0..6] of char = 'Window'#0;
ClsName: array[0..6] of char = 'Window'#0;
ButtonClsName: array[0..6] of char = 'Button'#0;
ComboboxClsName: array[0..8] of char = 'ComboBox'#0;
TabControlClsName: array[0..15] of char = 'SysTabControl32'#0;
{ export for widgetset implementation }
@ -191,6 +198,8 @@ function ComboBoxWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult; stdcall;
function ChildEditWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult; stdcall;
function CallDefaultWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult;
Implementation
@ -257,6 +266,10 @@ var
Initialization
Assert(False, 'Trace:win32int.pp - Initialization');
{$ifdef MSG_DEBUG}
MessageStackDepth := '';
{$endif}
EraseBkgndStack := 0;
Finalization
@ -267,6 +280,9 @@ End.
{ =============================================================================
$Log$
Revision 1.123 2004/10/27 20:58:58 micha
fix winxp theming for tabcontrols (shaded background)
Revision 1.122 2004/10/16 10:17:21 micha
remove statusbar helper methods from general widgetset object

11
lcl/interfaces/win32/win32proc.pp
View File

@ -57,6 +57,7 @@ function GetLCLClientBoundsOffset(Handle: HWnd; var Rect: TRect): boolean;
Procedure LCLBoundsToWin32Bounds(Sender: TObject;
var Left, Top, Width, Height: Integer);
Procedure Win32PosToLCLPos(Sender: TObject; var Left, Top: SmallInt);
procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
procedure UpdateWindowStyle(Handle: HWnd; Style: integer; StyleMask: integer);
function BorderStyleToWin32Flags(Style: TFormBorderStyle): DWORD;
function BorderStyleToWin32FlagsEx(Style: TFormBorderStyle): DWORD;
@ -792,6 +793,16 @@ Begin
dec(Top, ORect.Top);
End;
procedure GetWin32ControlPos(Window, Parent: HWND; var Left, Top: integer);
var
parRect, winRect: TRect;
begin
Windows.GetWindowRect(Window, winRect);
Windows.GetWindowRect(Parent, parRect);
Left := winRect.Left - parRect.Left;
Top := winRect.Top - parRect.Top;
end;
{
Updates the window style of the window indicated by Handle.
The new style is the Style parameter.

2
lcl/interfaces/win32/win32wscontrols.pp
View File

@ -216,6 +216,8 @@ begin
begin
// some controls (combobox) immediately send a message upon setting font
AWinControl.Handle := Window;
if Windows.GetProp(GetParent(Window), 'TabPageParent') <> 0 then
Windows.SetProp(Window, 'TabPageParent', 1);
Windows.SetProp(Window, 'Wincontrol', dword(AWinControl));
if SubClassWndProc <> nil then
Windows.SetProp(Window, 'DefWndProc', Windows.SetWindowLong(Window, GWL_WNDPROC, LongInt(SubClassWndProc)));

10
lcl/interfaces/win32/win32wsextctrls.pp
View File

@ -299,7 +299,7 @@ begin
with Params do
begin
pClassName := @ClsName;
Flags := Flags and DWORD(not WS_VISIBLE);
Flags := Flags and not WS_VISIBLE;
SubClassWndProc := nil;
CustomPageCalcBounds(AWinControl, Left, Top, Width, Height);
end;
@ -307,6 +307,11 @@ begin
FinishCreateWindow(AWinControl, Params, false);
// return window handle
Result := Params.Window;
if TWin32WidgetSet(InterfaceObject).ThemesActive then
begin
SetProp(Result, 'TabPageParent', 1);
SetProp(Result, 'TabPage', 1);
end;
end;
procedure TWin32WSCustomPage.SetBounds(const AWinControl: TWinControl;
@ -392,6 +397,9 @@ begin
// create window
FinishCreateWindow(AWinControl, Params, false);
Result := Params.Window;
// although we may be child of tabpage, cut the paint chain
// to improve speed and possible paint anomalities
Windows.RemoveProp(Result, 'TabPageParent');
end;
procedure TWin32WSCustomNotebook.AddPage(const ANotebook: TCustomNotebook;

24
lcl/interfaces/win32/win32wsstdctrls.pp
View File

@ -322,6 +322,20 @@ end;
{ TWin32WSCustomGroupBox }
function GroupBoxPanelWindowProc(Window: HWnd; Msg: UInt; WParam: Windows.WParam;
LParam: Windows.LParam): LResult; stdcall;
begin
// handle paint messages for theming
case Msg of
WM_ERASEBKGND, WM_NCPAINT, WM_PAINT, WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC:
begin
Result := WindowProc(Window, Msg, WParam, LParam);
end;
else
Result := CallDefaultWindowProc(Window, Msg, WParam, LParam);
end;
end;
function TWin32WSCustomGroupBox.CreateHandle(const AWinControl: TWinControl;
const AParams: TCreateParams): HWND;
var
@ -341,12 +355,18 @@ begin
// the bug is hidden. Use 'ParentPanel' property of groupbox window
// to determine reference to this parent panel
// do not use 'ParentPanel' property for other controls!
Parent := CreateWindowEx(0, @ClsName, nil, WS_CHILD or WS_CLIPSIBLINGS or (Flags and WS_VISIBLE),
Buddy := CreateWindowEx(0, @ClsName, nil, WS_CHILD or WS_CLIPCHILDREN or
WS_CLIPSIBLINGS or (Flags and WS_VISIBLE),
Left, Top, Width, Height, Parent, 0, HInstance, nil);
Buddy := Parent;
Left := 0;
Top := 0;
Flags := Flags or WS_VISIBLE;
// set P(aint)WinControl, for paint message to retrieve information
// about wincontrol (hack)
Windows.SetProp(Buddy, 'PWinControl', dword(AWinControl));
if Windows.GetProp(Parent, 'TabPageParent') <> 0 then
Windows.SetProp(Buddy, 'TabPageParent', 1);
Parent := Buddy;
end;
pClassName := 'BUTTON';
WindowTitle := StrCaption;