diff --git a/lcl/interfaces/win32/win32callback.inc b/lcl/interfaces/win32/win32callback.inc index 53e36458aa..997cc56ffc 100644 --- a/lcl/interfaces/win32/win32callback.inc +++ b/lcl/interfaces/win32/win32callback.inc @@ -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 diff --git a/lcl/interfaces/win32/win32int.pp b/lcl/interfaces/win32/win32int.pp index 37113aeecf..12e6eece78 100644 --- a/lcl/interfaces/win32/win32int.pp +++ b/lcl/interfaces/win32/win32int.pp @@ -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 diff --git a/lcl/interfaces/win32/win32proc.pp b/lcl/interfaces/win32/win32proc.pp index 91d31d85e2..2d3337cf25 100644 --- a/lcl/interfaces/win32/win32proc.pp +++ b/lcl/interfaces/win32/win32proc.pp @@ -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. diff --git a/lcl/interfaces/win32/win32wscontrols.pp b/lcl/interfaces/win32/win32wscontrols.pp index 84bf1a56bb..00873a27e5 100644 --- a/lcl/interfaces/win32/win32wscontrols.pp +++ b/lcl/interfaces/win32/win32wscontrols.pp @@ -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))); diff --git a/lcl/interfaces/win32/win32wsextctrls.pp b/lcl/interfaces/win32/win32wsextctrls.pp index bf26130154..97db36edb1 100644 --- a/lcl/interfaces/win32/win32wsextctrls.pp +++ b/lcl/interfaces/win32/win32wsextctrls.pp @@ -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; diff --git a/lcl/interfaces/win32/win32wsstdctrls.pp b/lcl/interfaces/win32/win32wsstdctrls.pp index 18f4977040..f3fa626320 100644 --- a/lcl/interfaces/win32/win32wsstdctrls.pp +++ b/lcl/interfaces/win32/win32wsstdctrls.pp @@ -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;