thememgr.pas

Last change: 2008-02-03 This is the source code of KCeasy。

unit ThemeMgr;

//----------------------------------------------------------------------------------------------------------------------
// Version 1.10.1
//
// Windows XP Theme Manager is freeware. You may freely use it in any software, including commercial software, provided
// you accept the following conditions:
//
// 1) The software may not be included into component collections and similar compilations which are sold. If you want
//    to distribute this software for money then contact me first and ask for my permission.
// 2) My copyright notices in the source code may not be removed or modified.
// 3) If you modify and/or distribute the code to any third party then you must not veil the original author. It must
//    always be clearly identifiable that I, Mike Lischke, am the original author.
// Although it is not required it would be a nice move to recognize my work by adding a citation to the application's
// about box or a similar place.
//
// The original code is ThemeMgr.pas, released 01. January 2002.
//
// The initial developer of the original code is:
//   Mike Lischke ([e-mail], www.soft-gems.net).
//
// Portions created by Mike Lischke are
// (C) 2001-2005 Mike Lischke. All Rights Reserved.
//----------------------------------------------------------------------------------------------------------------------
//
// This unit contains the implementation of TThemeManager which is designed to fix certain VCL components to enable
// XP theme support in Delphi and BCB applications (version 6 and lower).
//
// TThemeManager uses global theming (all windows in the application use the same theme). Hence you don't
// need more than one instance in an application (except for DLLs). Having more than one instance in the same module
// (application, DLL) will disable subclassing of controls by all other but the first instance.
//
// Note: If you are using a Theme Manager in a DLL then make sure the handle of the application object in the DLL (which
//       is usually not allocated) is set to that of the main application, e.g. by passing it via an exported function.
//----------------------------------------------------------------------------------------------------------------------
//
// January 2005
//   - Bug fix: Test for Windows XP was wrong.
// 
// For full development history see help file.
// 
// Credits for their valuable help go to:
//   Bert Moorthaemer, Rob Schoenaker, John W. Long, Vassiliev V.V., Steve Moss, Torsten Detsch, Milan Vandrovec
//----------------------------------------------------------------------------------------------------------------------

interface

{$I Compilers.inc}

{$ifdef COMPILER_7_UP}
  ATTENTION! Theme support is already included in this Borland product.
  Remove the Delphi Gems Theme Manager from your project to compile it correctly!
{$endif COMPILER_7_UP}

// The CheckListSupport switch is used to remove support for TCheckListBox. The main reason for this
// is that TCheckListBox is in a special package (VCLX??.dpk), which you may not want to have included
// (particularly when using runtime packages). Disable the switch to remove the link to the package
// and remove the package reference from the ThemeManagerX.dpk file).
{$define CheckListSupport}

uses
  Windows, Classes, Messages, Graphics, Controls, StdCtrls, Buttons, Forms,
  ThemeSrv;

const
  TMVersion = '1.10.1';

  // Sent to any control to give it a chance to deny its subclassing. This is mainly useful for controls
  // which are derived from classes which are usually subclassed by the Theme Manager but do their own
  // painting. A control should return a value <> 0 if subclassing should not be done.
  CM_DENYSUBCLASSING = CM_BASE + 2000;

  {$ifndef COMPILER_5_UP}
    {$EXTERNALSYM WM_CHANGEUISTATE}
    WM_CHANGEUISTATE = $0127;
    {$EXTERNALSYM WM_UPDATEUISTATE}
    WM_UPDATEUISTATE = $0128;
    {$EXTERNALSYM WM_QUERYUISTATE}
    WM_QUERYUISTATE = $0129;
    UIS_CLEAR = 2;
    UISF_HIDEFOCUS = 1;
    UISF_HIDEACCEL = 2;
  {$endif COMPILER_5_UP}

  // These constants are not defined in Delphi/BCB 6 or lower.
  SPI_GETFOCUSBORDERWIDTH = $200E;
  SPI_SETFOCUSBORDERWIDTH = $200F;
  SPI_GETFOCUSBORDERHEIGHT = $2010;
  SPI_SETFOCUSBORDERHEIGHT = $2011;

type
  TThemeOption = (
    toAllowNonClientArea,    // Specifies that the nonclient areas of application windows will have visual styles applied.
    toAllowControls,         // Specifies that the controls used in an application will have visual styles applied.
    toAllowWebContent,       // Specifies that Web content displayed in an application will have visual styles applied.

    toSubclassAnimate,       // Enables subclassing of TAnimate controls (themed painting does not correctly work).
    toSubclassButtons,       // Enables subclassing of button controls (also checkbox, radio button).
    toSubclassCheckListbox,  // Enables subclassing of TCheckListBox.
    toSubclassDBLookup,      // Enables subclassing of TDBLookupControl. Only used in TThemeManagerDB.
    toSubclassFrame,         // Enables subclassing of frames (only available in Delphi 5 or higher).
    toSubclassGroupBox,      // Enables subclassing of group box controls.
    toSubclassListView,      // Enables subclassing of listview controls (including report mode bug fix).
    toSubclassPanel,         // Enables subclassing of panels.
    toSubclassTabSheet,      // Enables subclassing of tab sheet controls.
    toSubclassSpeedButtons,  // Enables subclassing of speed button controls.
    toSubclassSplitter,      // Enables subclassing of splitter controls.
    toSubclassStatusBar,     // Enables subclassing of status bar controls.
    toSubclassTrackBar,      // Enables subclassing of track bar controls (slight paint problems, though).
    toSubclassWinControl,    // Enables subclassing of all window controls not belonging to any of the other classes.

    toResetMouseCapture,     // If set then TToolButtons get their csCaptureMouse flag removed to properly show
                             // their pressed state.
    toSetTransparency,       // If set then TCustomLabel and TToolBar controls are automatically set to transparent.
    toAlternateTabSheetDraw  // If set then use alternate drawing for TTabSheet body.
  );
  TThemeOptions = set of TThemeOption;

const
  DefaultThemeOptions = [toAllowNonClientArea..toAllowWebContent, toSubclassButtons..toSetTransparency];

type
  // These message records are not declared in Delphi 6 and lower.
  TWMPrint = packed record
    Msg: Cardinal;
    DC: HDC;
    Flags: Cardinal;
    Result: Integer;
  end;

  TWMPrintClient = TWMPrint;

  TThemeManager = class;

  TAllowSubclassingEvent = procedure(Sender: TThemeManager; Control: TControl; var Allow: Boolean) of object;
  TControlMessageEvent = procedure(Sender: TThemeManager; Control: TControl; var Message: TMessage;
    var Handled: Boolean) of object;

  PControlMessageEvent = ^TControlMessageEvent;

  // The window procedure list maintains the connections between control instances and their old window procedures.
  TWindowProcList = class(TList)
  private
    FDirty: Boolean;
    FLastControl: TControl;
    FLastIndex: Integer;
    FOwner: TThemeManager;
    FNewWindowProc: TWndMethod;   // The new window procedure which handles the corrections for the control class.
    FControlClass: TControlClass; // The class for which this list is responsible.
  public
    constructor Create(Owner: TThemeManager; WindowProc: TWndMethod; ControlClass: TControlClass);
    destructor Destroy; override;

    function Add(Control: TControl): Integer;
    procedure Clear; override;
    procedure DispatchMessage(Control: TControl; var Message: TMessage);
    function Find(Control: TControl; out Index: Integer): Boolean;
    procedure Remove(Control: TControl);
  end;

  // TThemeManager is a class whose primary task is to fix various issues which show up when an application
  // is themed.
  TThemeManager = class(TComponent)
  private
    FOptions: TThemeOptions;           // Determines which parts are allowed to be themed.
    FPanelList,
    {$ifdef COMPILER_5_UP}
      FFrameList,                      // Frames are first available in Delphi 5.
    {$endif COMPILER_5_UP}
    FListViewList,
    FTabSheetList,
    FWinControlList,
    FGroupBoxList,
    FButtonControlList,
    FSpeedButtonList,
    FSplitterList,
    FTrackBarList,
    FAnimateList,
    FStatusBarList,
    {$ifdef CheckListSupport}
      FCheckListBoxList,
    {$endif CheckListSupport}
    FFormList: TWindowProcList;
    FListeners: TList;
    FPendingFormsList: TList;
    FPendingRecreationList: TList;
    FSubclassingDisabled: Boolean;     // Disable subclassing generally (e.g. for multi instancing).
    FHookWasInstalled: Boolean;

    FOnThemeChange: TNotifyEvent;      // Called when the Windows theme or an application option has changed.
    FOnControlMessage: TControlMessageEvent;
    FOnAllowSubclassing: TAllowSubclassingEvent;
    procedure AnimateWindowProc(Control: TControl; var Message: TMessage);
    procedure ButtonControlWindowProc(Control: TControl; var Message: TMessage);
    {$ifdef CheckListSupport}
      procedure CheckListBoxWindowProc(Control: TControl; var Message: TMessage);
    {$endif CheckListSupport}
    procedure FormWindowProc(Control: TControl; var Message: TMessage);
    {$ifdef COMPILER_5_UP}
      procedure FrameWindowProc(Control: TControl; var Message: TMessage);
    {$endif COMPILER_5_UP}
    function GetIsMainManager: Boolean;
    procedure GroupBoxWindowProc(Control: TControl; var Message: TMessage);
    procedure ListviewWindowProc(Control: TControl; var Message: TMessage);
    function MainWindowHook(var Message: TMessage): Boolean;
    procedure PanelWindowProc(Control: TControl; var Message: TMessage);
    procedure SetThemeOptions(const Value: TThemeOptions);
    procedure SpeedButtonWindowProc(Control: TControl; var Message: TMessage);
    procedure SplitterWindowProc(Control: TControl; var Message: TMessage);
    procedure StatusBarWindowProc(Control: TControl; var Message: TMessage);
    procedure TabSheetWindowProc(Control: TControl; var Message: TMessage);
    procedure TrackBarWindowProc(Control: TControl; var Message: TMessage);
    procedure WinControlWindowProc(Control: TControl; var Message: TMessage);

    procedure PreAnimateWindowProc(var Message: TMessage);
    procedure PreButtonControlWindowProc(var Message: TMessage);
    {$ifdef CheckListSupport}
      procedure PreCheckListBoxWindowProc(var Message: TMessage);
    {$endif CheckListSupport}
    procedure PreFormWindowProc(var Message: TMessage);
    {$ifdef COMPILER_5_UP}
      procedure PreFrameWindowProc(var Message: TMessage);
    {$endif COMPILER_5_UP}
    procedure PreGroupBoxWindowProc(var Message: TMessage);
    procedure PreListviewWindowProc(var Message: TMessage);
    procedure PrePanelWindowProc(var Message: TMessage);
    procedure PreSpeedButtonWindowProc(var Message: TMessage);
    procedure PreSplitterWindowProc(var Message: TMessage);
    procedure PreStatusBarWindowProc(var Message: TMessage);
    procedure PreTabSheetWindowProc(var Message: TMessage);
    procedure PreTrackBarWindowProc(var Message: TMessage);
    procedure PreWinControlWindowProc(var Message: TMessage);
  protected
    procedure AddRecreationCandidate(Control: TControl); virtual;
    procedure BroadcastThemeChange;
    class function CurrentThemeManager: TThemeManager;
    function DoAllowSubclassing(Control: TControl): Boolean; virtual;
    function DoControlMessage(Control: TControl; var Message: TMessage): Boolean; virtual;
    procedure DoOnThemeChange; virtual;
    procedure DrawBitBtn(Control: TBitBtn; var DrawItemStruct: TDrawItemStruct);
    procedure DrawButton(Control: TControl; Button: TThemedButton; DC: HDC; R: TRect; Focused: Boolean);
    function FindListener(AControlMessage: TControlMessageEvent; var Index: Integer): Boolean;
    procedure FixControls(Form: TCustomForm = nil);
    procedure ForceAsMainManager; virtual;
    procedure HandleControlChange(Control: TControl; Inserting: Boolean); virtual;
    function IsRecreationCandidate(Control: TControl): Boolean;
    procedure Loaded; override;
    function NeedsBorderPaint(Control: TControl): Boolean; virtual;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure RemoveChildSubclassing(Control: TWinControl);
    procedure RemoveRecreationCandidate(Control: TControl);
    procedure UpdateThemes;
    procedure UpdateUIState(Control: TControl; CharCode: Word);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure ClearLists;
    procedure CollectForms(Form: TCustomForm = nil);
    procedure CollectControls(Parent: TWinControl);
    procedure PerformEraseBackground(Control: TControl; DC: HDC);
    procedure RegisterListener(AControlMessage: TControlMessageEvent);
    procedure UnregisterListener(AControlMessage: TControlMessageEvent);

    property IsMainManager: Boolean read GetIsMainManager;
  published
    property Options: TThemeOptions read FOptions write SetThemeOptions default DefaultThemeOptions;

    property OnAllowSubclassing: TAllowSubclassingEvent read FOnAllowSubclassing write FOnAllowSubclassing;
    property OnControlMessage: TControlMessageEvent read FOnControlMessage write FOnControlMessage;
    property OnThemeChange: TNotifyEvent read FOnThemeChange write FOnThemeChange;
  end;

var
  IsWindowsXP: Boolean;

//----------------------------------------------------------------------------------------------------------------------

implementation

uses
  SysUtils, ComCtrls, CommCtrl, SyncObjs, ExtCtrls, Grids, UxTheme
  {$ifdef CheckListSupport}
    , CheckLst
  {$endif CheckListSupport}
  ;

const
  WM_MAINMANAGERRELEASED = CN_NOTIFY + 100;

type
  {$ifndef COMPILER_6_UP}
    // TCustomStatusBar does not exist prior Delphi/BCB 6.
    TCustomStatusBar = TStatusBar;
  {$endif COMPILER_6_UP}
  
  PWindowProcEntry = ^TWindowProcEntry;
  TWindowProcEntry = record
    Control: TControl;
    OldWndProc: TWndMethod;
  end;

var
  Lock: TCriticalSection;

  {$ifdef Debug}
    SubclassCount: Integer;
  {$endif}

var
  MainManager: TThemeManager;
  GlobalCheckWidth,
  GlobalCheckHeight: Integer;

//----------------- Drawing helper routines ----------------------------------------------------------------------------

procedure GetCheckSize;

begin
  with TBitmap.Create do
  try
    Handle := LoadBitmap(0, PChar(32759));
    GlobalCheckWidth := Width div 4;
    GlobalCheckHeight := Height div 3;
  finally
    Free;
  end;
end;

//----------------------------------------------------------------------------------------------------------------------

type
  // Used to access protected properties.
  TControlCast = class(TControl);

procedure CalcButtonLayout(Control: TControl; DC: HDC; const Client: TRect; const Offset: TPoint; var GlyphPos: TPoint;
  var TextBounds: TRect; BiDiFlags: Integer);

// This routine is nearly the same as the same named version in TButtonGlyph. The inclusion here is necessary
// because we need the same layout as in the VCL but the implementation of TButtonGlyph is hidden in Buttons and
// cannot be made accessible from here.

var
  TextPos: TPoint;
  ClientSize,
  GlyphSize,
  TextSize: TPoint;
  TotalSize: TPoint;
  Layout: TButtonLayout;
  Spacing: Integer;
  Margin: Integer;
  Glyph: TBitmap;
  NumGlyphs: Integer;
  Caption: TCaption;
  
begin
  if Control is TBitBtn then
  begin
    Layout := TBitBtn(Control).Layout;
    Spacing := TBitBtn(Control).Spacing;
    Margin := TBitBtn(Control).Margin;
    Glyph := TBitBtn(Control).Glyph;