fix winxp theming for tabcontrols (shaded background)

git-svn-id: trunk@6167 -

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
+    if not (OwnerObject is TWinControl) then
-      exit;              
+    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
+    WinProcess := false;
-    begin
-      ORect.Left := 0;
-      ORect.Top := 0;
-      { we don't use ORect.Right and ORect.Bottom, initialize here if needed }
-    end;
     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);
+      if not hasTabParent and not isNotebook then
-      MoveWindowOrgEx(PaintMsg.DC, ORect.Left, ORect.Top);
+        AWinControl.EraseBackground(PaintMsg.DC);
-      DeliverMessage(OwnerObject, PaintMsg);
+      if parentPaint then
-      MoveWindowOrgEx(PaintMsg.DC, -ORect.Left, -ORect.Top);
+      begin
-      if AWinControl.DoubleBuffered then
+        // 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
+    begin
-      MsgObject := TObject(GetProp(LParam, 'Wincontrol'));
+      // only static and button controls have transparent parts
-      if MsgObject = nil then
+      // others need to erased with their window color
-        MsgObject := TObject(GetProp(LParam, 'AWincontrol'));
+      if ((Msg <> WM_CTLCOLORSTATIC) and (Msg <> WM_CTLCOLORBTN))
-      if MsgObject is TWinControl then
+          or (Windows.GetProp(LParam, 'TabPageParent') = 0) then
       begin
-        Windows.SetTextColor(HDC(WParam), Windows.COLORREF(ColorToRGB(TWinControl(MsgObject).Font.Color)));
+        MsgObject := TObject(GetProp(LParam, 'Wincontrol'));
-        Windows.SetBkColor(HDC(WParam), Windows.COLORREF(ColorToRGB(TWinControl(MsgObject).Brush.Color)));
+        if MsgObject = nil then
-        LMessage.Result := LResult(TWinControl(MsgObject).Brush.Handle);
+          MsgObject := TObject(GetProp(LParam, 'AWincontrol'));
-        // Override default handling
+        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;
+      eraseBkgndCommand := TEraseBkgndCommand(EraseBkgndStack and EraseBkgndStackMask);
-      LMessage.WParam := WParam;
+      EraseBkgndStack := EraseBkgndStack shr EraseBkgndStackShift;
-      LMessage.LParam := LParam;
+      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
 

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
 

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.

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)));

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; 

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;