- initial implementation of lazarus ThemeServices

- win32 calls to Widgetset.ThemesActive redirected to ThemeServices

git-svn-id: trunk@11161 -

.gitattributes

@@ -2615,6 +2615,7 @@ lcl/interfaces/gtk2/gtk2lclintfh.inc svneol=native#text/pascal
 lcl/interfaces/gtk2/gtk2memostrings.inc svneol=native#text/pascal
 lcl/interfaces/gtk2/gtk2object.inc svneol=native#text/pascal
 lcl/interfaces/gtk2/gtk2privatewidget.inc svneol=native#text/plain
+lcl/interfaces/gtk2/gtk2themes.pas svneol=native#text/pascal
 lcl/interfaces/gtk2/gtk2winapi.inc svneol=native#text/pascal
 lcl/interfaces/gtk2/gtk2winapih.inc svneol=native#text/pascal
 lcl/interfaces/gtk2/gtk2wsactnlist.pp svneol=native#text/pascal
@@ -2698,6 +2699,8 @@ lcl/interfaces/win32/win32listslh.inc svneol=native#text/pascal
 lcl/interfaces/win32/win32memostrings.inc svneol=native#text/pascal
 lcl/interfaces/win32/win32object.inc svneol=native#text/pascal
 lcl/interfaces/win32/win32proc.pp svneol=native#text/pascal
+lcl/interfaces/win32/win32themes.pas svneol=native#text/pascal
+lcl/interfaces/win32/win32uxtheme.pas svneol=native#text/pascal
 lcl/interfaces/win32/win32winapi.inc svneol=native#text/pascal
 lcl/interfaces/win32/win32winapih.inc svneol=native#text/pascal
 lcl/interfaces/win32/win32wsactnlist.pp svneol=native#text/pascal
@@ -2844,6 +2847,8 @@ lcl/tests/test5_1asyncprocess.lpi svneol=native#text/plain
 lcl/tests/test5_1asyncprocess.lpr svneol=native#text/plain
 lcl/tests/test5_1worker.pas svneol=native#text/plain
 lcl/textstrings.pas svneol=native#text/pascal
+lcl/themes.pas svneol=native#text/pascal
+lcl/tmschema.pas svneol=native#text/pascal
 lcl/toolwin.pp svneol=native#text/pascal
 lcl/translations.pas svneol=native#text/pascal
 lcl/utrace.pp svneol=native#text/pascal

lcl/alllclunits.pp

@@ -48,7 +48,7 @@ uses
   Printers, PostScriptPrinter, PostScriptCanvas, CheckLst, PairSplitter,
   ExtDlgs, DBCtrls, DBGrids, DBActns, EditBtn, ExtGraphics, ColorBox,
   PropertyStorage, IniPropStorage, XMLPropStorage, Chart, LDockTree, LDockCtrl,
-  CalendarPopup,
+  CalendarPopup, Themes,
   LCLMessageGlue,
   // widgetset skeleton
   WSActnList, WSArrow, WSButtons, WSCalendar,
@@ -67,3 +67,5 @@ implementation
 
 end.
 
+
+

lcl/include/interfacebase.inc

@@ -26,10 +26,12 @@
 constructor TWidgetSet.Create;
 begin
   inherited Create;
+  FThemeServices := CreateThemeServices;
 end;
 
 destructor TWidgetSet.Destroy;
 begin
+  FreeAndNil(FThemeServices);
   inherited Destroy;
 end;
 
@@ -37,6 +39,11 @@ procedure TWidgetSet.PassCmdLineOptions;
 begin
 end;
 
+function TWidgetSet.CreateThemeServices: TThemeServices;
+begin
+  Result := TThemeServices.Create;
+end;
+
 procedure TWidgetSet.AppRun(const ALoop: TApplicationMainLoop);
 begin
   if Assigned(ALoop) then ALoop;

lcl/interfacebase.pp

@@ -34,7 +34,7 @@ interface
 
 uses
   Types, Classes, SysUtils, Math, LCLStrConsts, LCLType, LCLProc, LMessages,
-  GraphType, GraphMath;
+  GraphType, GraphMath, Themes;
 
 type
   PEventHandler = type Pointer;
@@ -68,7 +68,9 @@ type
 
   TWidgetSet = class(TObject)
   protected
+    FThemeServices: TThemeServices;
     procedure PassCmdLineOptions; virtual;
+    function CreateThemeServices: TThemeServices; virtual;
   public
     constructor Create;
     destructor Destroy; override;
@@ -101,6 +103,8 @@ type
     {$I winapih.inc}
     {$I lclintfh.inc}
     {$UNDEF IF_BASE_MEMBER}
+    
+    property ThemeServices: TThemeServices read FThemeServices;
   end;
 
 type

lcl/interfaces/gtk2/gtk2int.pas

@@ -44,7 +44,7 @@ uses
   LMessages, Controls, Forms, LCLProc, LCLStrConsts, LCLIntf, LCLType,
   DynHashArray, GraphType, GraphMath, Graphics, Menus,
   GTKWinApiWindow, StdCtrls, ComCtrls,
-  Dialogs, ExtDlgs, LResources, Math, GTKGlobals,
+  Dialogs, ExtDlgs, Themes, LResources, Math, GTKGlobals,
   {Buttons, CListBox, Calendar, Arrow, Spin, FileCtrl, CommCtrl, ExtCtrls, }
   gtkDef, gtkFontCache, gtkInt, GtkExtra;
 
@@ -71,6 +71,8 @@ type
       SelWidget: PGtkWidget); override;
     procedure CreatePreviewDialogControl(
       PreviewDialog: TPreviewFileDialog; SelWidget: PGtkWidget); override;
+
+    function CreateThemeServices: TThemeServices; override;
   public
     function LCLPlatform: TLCLPlatform; override;
     {$I gtk2winapih.inc}
@@ -161,6 +163,7 @@ uses
 // Gtk2WSSpin,
  Gtk2WSStdCtrls,
 // Gtk2WSToolwin,
+ Gtk2Themes,
 ////////////////////////////////////////////////////
   gtkProc;
 

lcl/interfaces/gtk2/gtk2object.inc

@@ -906,6 +906,11 @@ begin
   gtk_widget_show(PreviewWidget);
 end;
 
+function TGtk2WidgetSet.CreateThemeServices: TThemeServices;
+begin
+  Result := TGtk2ThemeServices.Create;
+end;
+
 function TGtk2WidgetSet.LCLPlatform: TLCLPlatform;
 begin
   Result:= lpGtk2;

lcl/interfaces/gtk2/gtk2themes.pas

@@ -0,0 +1,309 @@
+unit Gtk2Themes;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  // rtl
+  Types, Classes, SysUtils,
+  // os
+  glib2,  gdk2, gtk2, Pango,
+  // lcl
+  LCLType, LCLProc, LCLIntf, Graphics, Themes, TmSchema,
+  // widgetset
+  gtkdef, gtk2int, gtkproc;
+  
+type
+  // todo: more common painter
+  TGtkPainter = procedure (style:PGtkStyle; window:PGdkWindow; state_type:TGtkStateType; shadow_type:TGtkShadowType; 
+     area:PGdkRectangle; widget:PGtkWidget; detail:Pgchar; x:gint; y:gint; width:gint; height:gint); cdecl;
+
+  TGtkPainterType =
+  (
+    gptDefault,
+    gptHLine,
+    gptVLine,
+    gptShadow,
+    gptBox,
+    gptFlatBox,
+    gptCheck,
+    gptOption,
+    gptTab
+//    gptSlider,
+//    gptHandle,
+//    gptExpander,
+//    gptResizeGrip
+  );
+
+  TGtkStyleParams = record
+    Style  : PGtkStyle;       // paint style
+    Painter: TGtkPainterType; // type of paint handler
+    Widget : PGtkWidget;      // widget
+    Window : PGdkWindow;      // paint window
+    Origin : TPoint;          // offset
+    State  : TGtkStateType;   // Style state
+    Shadow : TGtkShadowType;  // Shadow
+    Detail : String;          // Detail (button, checkbox, ...)
+  end;
+
+  { TGtk2ThemeServices }
+
+  TGtk2ThemeServices = class(TThemeServices)
+  private
+  protected
+    class function GtkStateFromDetails(Details: TThemedElementDetails): TGtkStateType;
+    class function GdkRectFromRect(R: TRect): TGdkRectangle;
+    class function GetGtkStyleParams(DC: HDC; Details: TThemedElementDetails): TGtkStyleParams;
+
+    function InitThemes: Boolean; override;
+    function UseThemes: Boolean; override;
+    function ThemedControlsEnabled: Boolean; override;
+
+    procedure InternalDrawParentBackground(Window: HWND; Target: HDC; Bounds: PRect); override;
+  public
+
+    procedure DrawElement(DC: HDC; Details: TThemedElementDetails; const R: TRect; ClipRect: PRect); override;
+    procedure DrawEdge(DC: HDC; Details: TThemedElementDetails; const R: TRect; Edge, Flags: Cardinal; AContentRect: PRect); override;
+    procedure DrawIcon(DC: HDC; Details: TThemedElementDetails; const R: TRect; himl: HIMAGELIST; Index: Integer); override;
+    procedure DrawText(DC: HDC; Details: TThemedElementDetails; const S: WideString; R: TRect; Flags, Flags2: Cardinal); override;
+
+    function ContentRect(DC: HDC; Details: TThemedElementDetails; BoundingRect: TRect): TRect; override;
+    function HasTransparentParts(Details: TThemedElementDetails): Boolean; override;
+  end;
+
+  procedure wrap_gtk_paint_hline(style:PGtkStyle; window:PGdkWindow; state_type:TGtkStateType; shadow_type:TGtkShadowType;
+     area:PGdkRectangle; widget:PGtkWidget; detail:Pgchar; x:gint; y:gint; width:gint; height:gint); cdecl;
+
+  procedure wrap_gtk_paint_vline(style:PGtkStyle; window:PGdkWindow; state_type:TGtkStateType; shadow_type:TGtkShadowType;
+     area:PGdkRectangle; widget:PGtkWidget; detail:Pgchar; x:gint; y:gint; width:gint; height:gint); cdecl;
+
+implementation
+
+const
+  GtkPainterMap: array[TGtkPainterType] of TGtkPainter =
+  (
+{ gptDefault    } @gtk_paint_box,          // maybe smth else ??
+{ gptHLine      } @wrap_gtk_paint_hline,
+{ gptVLine      } @wrap_gtk_paint_vline,
+{ gptShadow     } @gtk_paint_shadow,
+{ gptBox        } @gtk_paint_box,
+{ gptFlatBox    } @gtk_paint_flat_box,
+{ gptCheck      } @gtk_paint_check,
+{ gptOption     } @gtk_paint_option,
+{ gptTab,       } @gtk_paint_tab
+// { gptSlider     } @gtk_paint_slider,
+// { gptHandle     } @gtk_paint_handle,
+// { gptExpander   } @gtk_paint_expander,
+// { gptResizeGrip } @gtk_paint_resize_grip
+  );
+
+  // most common map
+  GtkStatesMap_0: array[0..6] of TGtkStateType =
+  (
+{ filter ?          } GTK_STATE_NORMAL,
+{ normal            } GTK_STATE_NORMAL,
+{ hot               } GTK_STATE_PRELIGHT,
+{ pressed           } GTK_STATE_ACTIVE,
+{ disabled          } GTK_STATE_INSENSITIVE,
+{ defaulted/checked } GTK_STATE_SELECTED,
+{ hot + checked     } GTK_STATE_SELECTED
+  );
+
+procedure wrap_gtk_paint_hline(style:PGtkStyle; window:PGdkWindow; state_type:TGtkStateType; shadow_type:TGtkShadowType;
+   area:PGdkRectangle; widget:PGtkWidget; detail:Pgchar; x:gint; y:gint; width:gint; height:gint); cdecl;
+begin
+  gtk_paint_hline(style, window, state_type, area, widget, detail, x, width, y);
+end;
+
+procedure wrap_gtk_paint_vline(style:PGtkStyle; window:PGdkWindow; state_type:TGtkStateType; shadow_type:TGtkShadowType;
+   area:PGdkRectangle; widget:PGtkWidget; detail:Pgchar; x:gint; y:gint; width:gint; height:gint); cdecl;
+begin
+  gtk_paint_vline(style, window, state_type, area, widget, detail, y, height, x);
+end;
+
+{ TGtk2ThemeServices }
+
+function TGtk2ThemeServices.GtkStateFromDetails(
+  Details: TThemedElementDetails): TGtkStateType;
+begin
+  Result := GTK_STATE_NORMAL;
+  case Details.Element of
+    teButton:
+      begin
+        case Details.Part of
+          BP_PUSHBUTTON: Result := GtkStatesMap_0[Details.State];
+        end;
+      end;
+    teToolBar:
+      begin
+        case Details.Part of
+          BP_PUSHBUTTON: Result := GtkStatesMap_0[Details.State];
+        end;
+      end;
+  end;
+end;
+
+function TGtk2ThemeServices.GdkRectFromRect(R: TRect): TGdkRectangle;
+begin
+  with Result, R do
+  begin
+    x := Left;
+    y := Top;
+    width := Right-Left;
+    height := Bottom-Top;
+  end;
+end;
+
+function TGtk2ThemeServices.GetGtkStyleParams(DC: HDC;
+  Details: TThemedElementDetails): TGtkStyleParams;
+var
+  ClientWidget: PGtkWidget;
+begin
+  Result.Style := nil;
+  
+  if GTK2WidgetSet.IsValidDC(DC) then
+    with TDeviceContext(DC) do
+    begin
+      Result.Widget := DCWidget;
+      ClientWidget := GetFixedWidget(Result.Widget);
+      if ClientWidget <> nil then
+        Result.Widget := ClientWidget;
+      Result.Window := Drawable;
+      Result.Origin := GetDCOffset(TDeviceContext(DC));
+      Result.Style := gtk_widget_get_style(Result.Widget);
+      if Result.Style = nil then
+        Result.Style := gtk_widget_get_default_style();
+      Result.State := GtkStateFromDetails(Details);
+      
+      // todo: shadow customization
+      Result.Shadow := GTK_SHADOW_IN;
+      
+      // todo: detail customization
+      Result.Detail := 'button';
+      
+      case Details.Element of
+        teButton : Result.Painter := gptBox;
+        teToolBar: Result.Painter := gptFlatBox;
+      else
+        Result.Painter := gptDefault;
+      end;
+    end;
+end;
+
+function TGtk2ThemeServices.InitThemes: Boolean;
+begin
+  Result := True;
+end;
+
+function TGtk2ThemeServices.UseThemes: Boolean;
+begin
+  Result := True;
+end;
+
+function TGtk2ThemeServices.ThemedControlsEnabled: Boolean;
+begin
+  Result := True;
+end;
+
+function TGtk2ThemeServices.ContentRect(DC: HDC;
+  Details: TThemedElementDetails; BoundingRect: TRect): TRect;
+var
+  StyleParams: TGtkStyleParams;
+begin
+  Result := BoundingRect;
+  StyleParams := GetGtkStyleParams(DC, Details);
+  if StyleParams.Style <> nil then
+    InflateRect(Result,
+      -StyleParams.Style^.xthickness,
+      -StyleParams.Style^.ythickness);
+end;
+
+procedure TGtk2ThemeServices.DrawEdge(DC: HDC;
+  Details: TThemedElementDetails; const R: TRect; Edge, Flags: Cardinal;
+  AContentRect: PRect);
+begin
+
+end;
+
+procedure TGtk2ThemeServices.DrawElement(DC: HDC;
+  Details: TThemedElementDetails; const R: TRect; ClipRect: PRect);
+var
+  ClipArea: TGdkRectangle;
+  p_ClipArea: PGdkRectangle;
+  StyleParams: TGtkStyleParams;
+begin
+  // todo:
+  // - gtk_paint_... customization
+  // - draw focus when needed
+  StyleParams := GetGtkStyleParams(DC, Details);
+  if StyleParams.Style <> nil then
+  begin
+    if ClipRect <> nil then
+    begin
+      ClipArea := GdkRectFromRect(ClipRect^);
+      inc(ClipArea.x, StyleParams.Origin.x);
+      inc(ClipArea.y, StyleParams.Origin.y);
+      p_ClipArea := @ClipArea;
+    end
+    else
+      p_ClipArea := nil;
+
+    with StyleParams do
+    begin
+      GtkPainterMap[Painter](
+          Style, Window,
+          State, Shadow,
+          p_ClipArea, Widget, PChar(Detail),
+          R.Left + Origin.x, R.Top + Origin.y,
+          R.Right - R.Left, R.Bottom - R.Top);
+
+     {  // for test
+      gtk_paint_focus(Style, Window,
+        State,
+        p_ClipArea, Widget, 'button',
+        R.Left + Origin.x, R.Top + Origin.y,
+        R.Right - R.Left, R.Bottom - R.Top);}
+    end;
+  end;
+end;
+
+procedure TGtk2ThemeServices.DrawIcon(DC: HDC;
+  Details: TThemedElementDetails; const R: TRect; himl: HIMAGELIST;
+  Index: Integer);
+begin
+
+end;
+
+function TGtk2ThemeServices.HasTransparentParts(Details: TThemedElementDetails): Boolean;
+begin
+  Result := True; // ?
+end;
+
+procedure TGtk2ThemeServices.InternalDrawParentBackground(Window: HWND;
+  Target: HDC; Bounds: PRect);
+begin
+  // ?
+end;
+
+procedure TGtk2ThemeServices.DrawText(DC: HDC; Details: TThemedElementDetails;
+  const S: WideString; R: TRect; Flags, Flags2: Cardinal);
+var
+  StyleParams: TGtkStyleParams;
+  P: PChar;
+  tmpRect: TRect;
+begin
+  StyleParams := GetGtkStyleParams(DC, Details);
+  if StyleParams.Style <> nil then
+    with StyleParams do
+    begin
+      P := PChar(String(S));
+      tmpRect := R;
+      Gtk2Widgetset.DrawText(DC, P, Length(S), tmpRect, Flags);
+      // TODO: parse flags
+      //gtk_draw_string(Style, Window, State, R.Left + Origin.x, R.Top + Origin.y, P);
+    end;
+end;
+
+end.
+

lcl/interfaces/win32/win32callback.inc

@@ -323,7 +323,7 @@ Var
 
     // create a paint message
     GetClassName(Window, winClassName, 20);
-    isNotebook := TWin32WidgetSet(WidgetSet).ThemesActive and
+    isNotebook := ThemeServices.ThemesEnabled and
       CompareMem(@winClassName, @TabControlClsName, High(TabControlClsName)+1);
     isNativeControl := not CompareMem(@winClassName, @ClsName, High(ClsName)+1);
     ParentPaintWindow := 0;
@@ -352,7 +352,7 @@ Var
 
     // check if double buffering is requested
     useDoubleBuffer := (ControlDC = 0) and (lWinControl.DoubleBuffered
-      or TWin32WidgetSet(WidgetSet).ThemesActive);
+      or ThemeServices.ThemesEnabled);
 {$ifdef MSG_DEBUG}
     if useDoubleBuffer and (DoubleBufferDC <> 0) then
     begin
@@ -390,10 +390,10 @@ Var
       if ControlDC = 0 then
       begin
         // ignore first erase background on themed control, paint will do everything
-        if TWin32WidgetSet(WidgetSet).ThemesActive then
+        if ThemeServices.ThemesEnabled then
           PushEraseBkgndCommand(ecDoubleBufferNoRemove);
         DC := Windows.BeginPaint(Window, @PS);
-        if TWin32WidgetSet(WidgetSet).ThemesActive then
+        if ThemeServices.ThemesEnabled then
           EraseBkgndStack := EraseBkgndStack shr EraseBkgndStackShift;
         if useDoubleBuffer then
         begin
@@ -1325,7 +1325,7 @@ begin
       // ugly hack to give bitbtns a nice look
       // When no theming active, the internal image needs to be
       // recreated when the enabled state is changed
-      if not TWin32WidgetSet(WidgetSet).ThemesActive
+      if not ThemeServices.ThemesEnabled
       and (lWinControl is TCustomBitBtn)
       then DrawBitBtnImage(TCustomBitBtn(lWinControl), PChar(TCustomBitBtn(lWinControl).Caption));
     End;
@@ -1356,7 +1356,7 @@ begin
       end;
       if not GetNeedParentPaint(WindowInfo, lWinControl) or (eraseBkgndCommand = ecDoubleBufferNoRemove) then
       begin
-        if TWin32WidgetSet(WidgetSet).ThemesActive and WindowInfo^.isGroupBox
+        if ThemeServices.ThemesEnabled and WindowInfo^.isGroupBox
             and (lWinControl <> nil) then
         begin
           // Groupbox (which is a button) doesn't erase it's background properly; force repaint
@@ -1944,7 +1944,8 @@ begin
     WM_THEMECHANGED:
     begin
       // winxp theme changed, recheck whether themes are enabled
-      TWin32WidgetSet(WidgetSet).UpdateThemesActive;
+      ThemeServices.UpdateThemes;
+      ThemeServices.IntfDoOnThemeChange;
     end;
 
     { >= WM_USER }

lcl/interfaces/win32/win32int.pp

@@ -43,7 +43,7 @@ Interface
 Uses
   Windows, Classes, ComCtrls, Controls, Buttons, Dialogs, DynHashArray,
   ExtCtrls, Forms, GraphMath, GraphType, InterfaceBase, LCLIntf, LCLType,
-  LMessages, StdCtrls, SysUtils, Win32Def, Graphics, Menus, CommCtrl;
+  LMessages, StdCtrls, SysUtils, Win32Def, Graphics, Menus, CommCtrl, Themes;
 
 const
 
@@ -148,10 +148,6 @@ Type
     FWaitHandlers: array of TWaitHandler;
     FWaitPipeHandlers: PPipeEventInfo;
 
-    FThemesActive: boolean;
-    FThemeLibrary: HMODULE;
-    IsThemeActive: function: LongBool; stdcall;
-    IsAppThemed: function: LongBool; stdcall;
     InitCommonControlsEx: function(ICC: PInitCommonControlsEx): LongBool; stdcall;
 
     FOnAsyncSocketMsg: TSocketEvent;
@@ -172,6 +168,7 @@ Type
     Procedure NormalizeIconName(Var IconName: String);
     Procedure NormalizeIconName(Var IconName: PChar);
 
+    function CreateThemeServices: TThemeServices; override;
   Public
     { Creates a callback of Lazarus message Msg for Sender }
     Procedure SetCallback(Msg: LongInt; Sender: TObject); virtual;
@@ -203,7 +200,6 @@ Type
     procedure DCRedraw(CanvasHandle: HDC); override;
     procedure SetDesigning(AComponent: TComponent); override;
 
-    procedure UpdateThemesActive;
     procedure ShowHide(Sender: TObject);
 
     // create and destroy
@@ -219,7 +215,6 @@ Type
 
     property AppHandle: HWND read FAppHandle;
     property MessageFont: HFONT read FMessageFont;
-    property ThemesActive: boolean read FThemesActive;
     property OnAsyncSocketMsg: TSocketEvent read FOnAsyncSocketMsg write FOnAsyncSocketMsg;
   End;
 
@@ -282,6 +277,7 @@ Uses
  Win32WSSpin,
  Win32WSStdCtrls,
 // Win32WSToolwin,
+ Win32Themes,
 ////////////////////////////////////////////////////
  Arrow, Calendar, Spin, CheckLst, WinExt, LclProc;
 

lcl/interfaces/win32/win32object.inc

@@ -40,25 +40,7 @@ Begin
     FMetrics.iMenuHeight := GetSystemMetrics(SM_CYMENU);
   end;
   OnClipBoardRequest := nil;
-  // see if XP themes are available, first check if correct
-  // common control library is loaded for themes support
-  if ((GetFileVersion('comctl32.dll') shr 16) and $FFFF) >= 6 then
-  begin
-    FThemeLibrary := LoadLibrary('uxtheme.dll');
-    if FThemeLibrary <> 0 then
-    begin
-      // load functions
-      Pointer(IsThemeActive) := GetProcAddress(FThemeLibrary, 'IsThemeActive');
-      Pointer(IsAppThemed) := GetProcAddress(FThemeLibrary, 'IsAppThemed');
-    end else begin
-      IsThemeActive := nil;
-      IsAppThemed := nil;
-    end;
-  end;
   Pointer(InitCommonControlsEx) := GetProcAddress(GetModuleHandle('comctl32.dll'), 'InitCommonControlsEx');
-
-  // init
-  UpdateThemesActive;
 End;
 
 {------------------------------------------------------------------------------
@@ -110,10 +92,6 @@ Begin
     DestroyWindow(FAppHandle);
 
   Windows.UnregisterClass(@ClsName, System.HInstance);
-
-  if FThemeLibrary <> 0 then
-    FreeLibrary(FThemeLibrary);
-
   inherited Destroy;
 End;
 
@@ -574,21 +552,6 @@ Begin
   Assert(False, 'Trace:WinRegister - Exit');
 End;
 
-{------------------------------------------------------------------------------
-  Method: TWin32WidgetSet.UpdateThemesActive
-  Params:  None
-  Returns: Nothing
-
-  Updates the field FThemesActive to save whether xp themes are active
- ------------------------------------------------------------------------------}
-procedure TWin32WidgetSet.UpdateThemesActive;
-begin
-  if (IsThemeActive <> nil) and (IsAppThemed <> nil) then
-    FThemesActive := IsThemeActive() and IsAppThemed()
-  else
-    FThemesActive := false;
-end;
-
 {------------------------------------------------------------------------------
   Method: TWin32WidgetSet.NormalizeIconName
   Params: IconName - The name of the icon to normalize
@@ -618,6 +581,11 @@ Begin
   IconName := StrToPChar(Str);
 End;
 
+function TWin32WidgetSet.CreateThemeServices: TThemeServices;
+begin
+  Result := TWin32ThemeServices.Create;
+end;
+
  {------------------------------------------------------------------------------
   Function: TWin32WidgetSet.CreateComponent
   Params:   Sender - object for which to create visual representation

lcl/interfaces/win32/win32themes.pas

@@ -0,0 +1,273 @@
+unit Win32Themes;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  // os
+  Windows, Win32UxTheme, Win32Proc,
+  // rtl
+  Classes, SysUtils,
+  // lcl
+  Graphics, Themes;
+  
+type
+
+  TThemeData = array[TThemedElement] of HTHEME;
+  { TWin32ThemeServices }
+
+  TWin32ThemeServices = class(TThemeServices)
+  private
+    FThemeData: TThemeData;            // Holds a list of theme data handles.
+  protected
+    function GetTheme(Element: TThemedElement): HTHEME;
+    property Theme[Element: TThemedElement]: HTHEME read GetTheme;
+    function InitThemes: Boolean; override;
+    procedure UnloadThemeData; override;
+    function UseThemes: Boolean; override;
+    function ThemedControlsEnabled: Boolean; override;
+    
+    function InternalColorToRGB(Details: TThemedElementDetails; Color: TColor): LongInt; override;
+    procedure InternalDrawParentBackground(Window: HWND; Target: HDC; Bounds: PRect); override;
+  public
+    destructor Destroy; override;
+
+    procedure DrawElement(DC: HDC; Details: TThemedElementDetails; const R: TRect;
+      ClipRect: PRect = nil); override;
+    procedure DrawEdge(DC: HDC; Details: TThemedElementDetails; const R: TRect; Edge, Flags: Cardinal;
+      AContentRect: PRect = nil); override;
+    procedure DrawIcon(DC: HDC; Details: TThemedElementDetails; const R: TRect;
+      himl: HIMAGELIST; Index: Integer); override;
+      
+    procedure DrawText(DC: HDC; Details: TThemedElementDetails; const S: WideString; R: TRect; Flags, Flags2: Cardinal); override;
+    procedure DrawText(ACanvas: TPersistent; Details: TThemedElementDetails; const S: WideString; R: TRect; Flags, Flags2: Cardinal); override;
+
+    function ContentRect(DC: HDC; Details: TThemedElementDetails; BoundingRect: TRect): TRect; override;
+    function HasTransparentParts(Details: TThemedElementDetails): Boolean; override;
+    procedure PaintBorder(Control: TObject; EraseLRCorner: Boolean); override;
+  end;
+
+implementation
+
+uses
+  Controls;
+
+const
+  ComCtlVersionIE6 = $00060000;
+  
+  ThemeDataNames: array[TThemedElement] of PWideChar = (
+    'button',      // teButton
+    'clock',       // teClock
+    'combobox',    // teComboBox
+    'edit',        // teEdit
+    'explorerbar', // teExplorerBar
+    'header',      // teHeader
+    'listview',    // teListView
+    'menu',        // teMenu
+    'page',        // tePage
+    'progress',    // teProgress
+    'rebar',       // teRebar
+    'scrollbar',   // teScrollBar
+    'spin',        // teSpin
+    'startpanel',  // teStartPanel
+    'status',      // teStatus
+    'tab',         // teTab
+    'taskband',    // teTaskBand
+    'taskbar',     // teTaskBar
+    'toolbar',     // teToolBar
+    'tooltip',     // teToolTip
+    'trackbar',    // teTrackBar
+    'traynotify',  // teTrayNotify
+    'treeview',    // teTreeview
+    'window'       // teWindow
+  );
+
+{ TWin32ThemeServices }
+
+procedure TWin32ThemeServices.UnloadThemeData;
+var
+  Entry: TThemedElement;
+begin
+  for Entry := Low(TThemeData) to High(TThemeData) do
+    if FThemeData[Entry] <> 0 then
+    begin
+      CloseThemeData(FThemeData[Entry]);
+      FThemeData[Entry] := 0;
+    end;
+end;
+
+function TWin32ThemeServices.InitThemes: Boolean;
+begin
+  Result := InitThemeLibrary;
+  FillChar(FThemeData, SizeOf(FThemeData), 0);
+end;
+
+destructor TWin32ThemeServices.Destroy;
+begin
+  inherited Destroy;
+  FreeThemeLibrary;
+end;
+
+function TWin32ThemeServices.UseThemes: Boolean;
+begin
+  Result := Win32UxTheme.UseThemes and (GetFileVersion(comctl32) >= ComCtlVersionIE6);
+end;
+
+function TWin32ThemeServices.ThemedControlsEnabled: Boolean;
+var
+  Flags: DWORD;
+begin
+  Flags := Win32UxTheme.GetThemeAppProperties();
+  if (Flags and STAP_ALLOW_CONTROLS) = 0 then
+    Result := False
+  else
+    Result := True;
+end;
+
+function TWin32ThemeServices.GetTheme(Element: TThemedElement): HTHEME;
+begin
+  if (FThemeData[Element] = 0) then
+    FThemeData[Element] := OpenThemeData(0, ThemeDataNames[Element]);
+  Result := FThemeData[Element];
+end;
+
+function TWin32ThemeServices.InternalColorToRGB(Details: TThemedElementDetails; Color: TColor): LongInt;
+begin
+  if ThemesEnabled then
+    Result := GetThemeSysColor(Theme[Details.Element], Color and not $80000000)
+  else
+    Result := inherited;
+end;
+
+function TWin32ThemeServices.ContentRect(DC: HDC; Details: TThemedElementDetails; BoundingRect: TRect): TRect;
+begin
+  if ThemesEnabled then
+    with Details do
+      GetThemeBackgroundContentRect(Theme[Element], DC, Part, State, BoundingRect, @Result)
+  else
+    Result := inherited;
+end;
+
+procedure TWin32ThemeServices.DrawEdge(DC: HDC; Details: TThemedElementDetails; const R: TRect; Edge, Flags: Cardinal;
+      AContentRect: PRect = nil);
+begin
+  if ThemesEnabled then
+    with Details do
+      DrawThemeEdge(Theme[Element], DC, Part, State, R, Edge, Flags, AContentRect)
+  else
+    inherited;
+end;
+
+procedure TWin32ThemeServices.DrawElement(DC: HDC; Details: TThemedElementDetails; const R: TRect; ClipRect: PRect = nil);
+begin
+  if ThemesEnabled then
+    with Details do
+      DrawThemeBackground(Theme[Element], DC, Part, State, R, ClipRect)
+  else
+    inherited;
+end;
+
+procedure TWin32ThemeServices.DrawIcon(DC: HDC; Details: TThemedElementDetails;
+  const R: TRect; himl: HIMAGELIST; Index: Integer);
+begin
+  if ThemesEnabled then
+    with Details do
+      DrawThemeIcon(Theme[Element], DC, Part, State, R, himl, Index)
+  else
+    inherited;
+end;
+
+function TWin32ThemeServices.HasTransparentParts(Details: TThemedElementDetails): Boolean;
+begin
+  if ThemesEnabled then
+    with Details do
+      Result := IsThemeBackgroundPartiallyTransparent(Theme[Element], Part, State)
+   else
+     Result := inherited;
+end;
+
+procedure TWin32ThemeServices.PaintBorder(Control: TObject;
+  EraseLRCorner: Boolean);
+var
+  EmptyRect,
+  DrawRect: TRect;
+  DC: HDC;
+  H, W: Integer;
+  AStyle,
+  ExStyle: Integer;
+  Details: TThemedElementDetails;
+begin
+  if not (Control is TWinControl) then
+    Exit;
+
+  if not ThemesEnabled then
+  begin
+    inherited;
+    Exit;
+  end;
+
+  with TWinControl(Control) do
+  begin
+    ExStyle := GetWindowLong(Handle, GWL_EXSTYLE);
+    if (ExStyle and WS_EX_CLIENTEDGE) <> 0 then
+    begin
+      GetWindowRect(Handle, DrawRect);
+      OffsetRect(DrawRect, -DrawRect.Left, -DrawRect.Top);
+      DC := GetWindowDC(Handle);
+      try
+        EmptyRect := DrawRect;
+        if EraseLRCorner then
+        begin
+          AStyle := GetWindowLong(Handle, GWL_STYLE);
+          if ((AStyle and WS_HSCROLL) <> 0) and ((AStyle and WS_VSCROLL) <> 0) then
+          begin
+            W := GetSystemMetrics(SM_CXVSCROLL);
+            H := GetSystemMetrics(SM_CYHSCROLL);
+            InflateRect(EmptyRect, -2, -2);
+            with EmptyRect do
+              EmptyRect := Rect(Right - W, Bottom - H, Right, Bottom);
+            FillRect(DC, EmptyRect, GetSysColorBrush(COLOR_BTNFACE));
+          end;
+        end;
+        with DrawRect do
+          ExcludeClipRect(DC, Left + 2, Top + 2, Right - 2, Bottom - 2);
+        Details := ThemeServices.GetElementDetails(teEditTextNormal);
+        DrawElement(DC, Details, DrawRect, nil);
+      finally
+        ReleaseDC(Handle, DC);
+      end;
+    end;
+  end;
+end;
+
+procedure TWin32ThemeServices.InternalDrawParentBackground(Window: HWND;
+  Target: HDC; Bounds: PRect);
+begin
+  if ThemesEnabled then
+    DrawThemeParentBackground(Window, Target, Bounds)
+  else
+    inherited;
+end;
+
+procedure TWin32ThemeServices.DrawText(DC: HDC; Details: TThemedElementDetails;
+  const S: WideString; R: TRect; Flags, Flags2: Cardinal);
+begin
+  if ThemesEnabled then
+    with Details do
+      DrawThemeText(Theme[Element], DC, Part, State, PWideChar(S), Length(S), Flags, Flags2, R)
+  else
+    inherited;
+end;
+
+procedure TWin32ThemeServices.DrawText(ACanvas: TPersistent;
+  Details: TThemedElementDetails; const S: WideString; R: TRect; Flags,
+  Flags2: Cardinal);
+begin
+  if ThemesEnabled then
+    DrawText(TCanvas(ACanvas).Handle, Details, S, R, Flags, Flags2)
+  else
+    inherited;
+end;
+
+end.

lcl/interfaces/win32/win32wsbuttons.pp

@@ -83,7 +83,7 @@ procedure DrawBitBtnImage(BitBtn: TCustomBitBtn; ButtonCaption: PChar);
 implementation
 
 uses
-  Win32Int, InterfaceBase, Win32Proc;
+  Win32Int, InterfaceBase, Win32Proc, Themes;
 
 { TWin32WSButton }
 
@@ -235,9 +235,10 @@ var
       if MaskBmp <> 0 then
         BitBlt(hdcNewBitmap, XDestBitmap, YDestBitmap, glyphWidth,
           glyphHeight, MaskDC, glyphLeft, 0, SRCCOPY);
-    end else begin
+    end else
+    begin
       // when not themed, windows wants a white background picture for disabled button image
-      themesActive := TWin32WidgetSet(WidgetSet).ThemesActive;
+      themesActive := ThemeServices.ThemesEnabled;
       if not themesActive then
         FillRect(hdcNewBitmap, BitmapRect, GetStockObject(WHITE_BRUSH));
       if BitmapHandle <> 0 then
@@ -399,7 +400,7 @@ begin
   end;
 
   // destroy previous bitmap, set new bitmap
-  if TWin32WidgetSet(WidgetSet).ThemesActive then
+  if ThemeServices.ThemesEnabled then
   begin
     // winxp draws BM_SETIMAGE bitmap with old style button!
     // need to use BCM_SETIMAGELIST

lcl/interfaces/win32/win32wsextctrls.pp

@@ -221,7 +221,7 @@ function  NotebookPageRealToLCLIndex(const ANotebook: TCustomNotebook; AIndex: i
 implementation
 
 uses
-  LMessages;
+  LMessages, Themes;
 
 function IsNotebookGroupFocused(const ANotebook: TCustomNotebook): boolean;
 var
@@ -305,12 +305,12 @@ begin
   FinishCreateWindow(AWinControl, Params, false);
   // return window handle
   Result := Params.Window;
-  if TWin32WidgetSet(WidgetSet).ThemesActive then
-  with Params.WindowInfo^ do
-  begin
-    needParentPaint := true;
-    isTabPage := true;
-  end;
+  if ThemeServices.ThemesEnabled then
+    with Params.WindowInfo^ do
+    begin
+      needParentPaint := true;
+      isTabPage := true;
+    end;
 end;
 
 class procedure TWin32WSCustomPage.SetText(const AWinControl: TWinControl; const AText: string);

lcl/interfaces/win32/win32wsstdctrls.pp

@@ -288,7 +288,9 @@ procedure EditSetSelLength(WinHandle: HWND; NewLength: integer);
 {$UNDEF MEMOHEADER}
 
 implementation
-
+uses
+  Themes;
+  
 const
   AlignmentMap: array[TAlignment] of DWORD =
   (
@@ -379,7 +381,7 @@ begin
   // customization of Params
   with Params do
   begin
-    if TWin32WidgetSet(WidgetSet).ThemesActive and (AWinControl.Parent <> nil) and
+    if ThemeServices.ThemesEnabled and (AWinControl.Parent <> nil) and
       (AWinControl.Parent is TCustomGroupBox) then
     begin
       // the parent of this groupbox is another groupbox: there is a bug in
@@ -421,8 +423,7 @@ begin
   end;
   // if themed but does not have tabpage as parent
   // remember we are a groupbox in need of erasebackground hack
-  if TWin32WidgetSet(WidgetSet).ThemesActive
-      and not Params.WindowInfo^.needParentPaint then
+  if ThemeServices.ThemesEnabled and not Params.WindowInfo^.needParentPaint then
     Params.WindowInfo^.isGroupBox := true;
   AWinControl.InvalidateClientRectCache(true);
   Result := Params.Window;

lcl/lcltype.pp

@@ -87,6 +87,7 @@ type
   HRGN  = type THandle;
   HINST = type THandle;
   HICON = type THandle;
+  HIMAGELIST = type THandle;
   HCURSOR = HICON;
   HGLOBAL = type THandle;
   HWND    = type THandle;
@@ -114,6 +115,7 @@ type
   HRGN    = Windows.HRGN;
   HINST   = Windows.HINST;
   HICON   = Windows.HICON;
+  HIMAGELIST = Windows.HIMAGELIST;
   HCURSOR = HICON;
   BOOL    = Windows.BOOL;
   HGLOBAL = Windows.HGLOBAL;