cxlookandfeels.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,008 行 · 第 1/3 页

{********************************************************************}
{                                                                    }
{       Developer Express Visual Component Library                   }
{       ExpressCommonLibrary                                         }
{                                                                    }
{       Copyright (c) 1998-2008 Developer Express Inc.               }
{       ALL RIGHTS RESERVED                                          }
{                                                                    }
{   The entire contents of this file is protected by U.S. and        }
{   International Copyright Laws. Unauthorized reproduction,         }
{   reverse-engineering, and distribution of all or any portion of   }
{   the code contained in this file is strictly prohibited and may   }
{   result in severe civil and criminal penalties and will be        }
{   prosecuted to the maximum extent possible under the law.         }
{                                                                    }
{   RESTRICTIONS                                                     }
{                                                                    }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES            }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE     }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS    }
{   LICENSED TO DISTRIBUTE THE EXPRESSCOMMONLIBRARY AND ALL          }
{   ACCOMPANYING VCL CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY. }
{                                                                    }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED       }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE         }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE        }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT   }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                       }
{                                                                    }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON        }
{   ADDITIONAL RESTRICTIONS.                                         }
{                                                                    }
{********************************************************************}

unit cxLookAndFeels;

{$I cxVer.inc}

interface

uses
  dxThemeManager, Messages, dxOffice11,
  SysUtils, Controls, Forms, Classes, cxClasses, cxLookAndFeelPainters;

type
  { TcxLookAndFeel }

  TcxLookAndFeelKind = (lfFlat, lfStandard, lfUltraFlat, lfOffice11);
  TcxLookAndFeelValue = (lfvKind, lfvNativeStyle, lfvSkinName);
  TcxLookAndFeelValues = set of TcxLookAndFeelValue;

const
  cxDefaultLookAndFeelKind = lfUltraFlat;
  cxDefaultLookAndFeelNativeStyle = False;
  cxDefaultLookAndFeelSkinName = '';
  cxUseSkins: Boolean = True;

type
  TcxLookAndFeel = class;
  TcxSystemPaletteChangedNotifier = class;

  IcxLookAndFeelNotificationListener = interface
  ['{205538BF-F19E-4285-B11F-B182D9635881}']
    function GetObject: TObject;
    procedure MasterLookAndFeelChanged(Sender: TcxLookAndFeel; AChangedValues: TcxLookAndFeelValues);
    procedure MasterLookAndFeelDestroying(Sender: TcxLookAndFeel);
  end;

  IdxSkinSupport = interface
  ['{EF3FF483-9B69-46DF-95A4-D3A3810F63A5}']
  end;
  
  { IcxLookAndFeelContainer }

  IcxLookAndFeelContainer = interface
    ['{6065B58B-C557-4464-A67D-64183FD13F25}']
    function GetLookAndFeel: TcxLookAndFeel;
  end;

  { TcxLookAndFeel }

  TcxLookAndFeelChangedEvent = procedure(Sender: TcxLookAndFeel; AChangedValues: TcxLookAndFeelValues) of object;

  TcxLookAndFeelData = record
    Kind: TcxLookAndFeelKind;
    NativeStyle: Boolean;
    SkinName: string;
    Painter: TcxCustomLookAndFeelPainterClass;
  end;

  TcxLookAndFeel = class(TcxInterfacedPersistent, IcxLookAndFeelNotificationListener, IcxLookAndFeelPainterListener)
  private
    FAssignedValues: TcxLookAndFeelValues;
    FChangeListenerList: TList;
    FCurrentState: TcxLookAndFeelData;
    FData: TcxLookAndFeelData;
    FIsDestruction: Boolean;
    FIsRootLookAndFeel: Boolean;
    FMasterLookAndFeel: TcxLookAndFeel;
    FPainter: TcxCustomLookAndFeelPainterClass;
    FSkinPainter: TcxCustomLookAndFeelPainterClass;
    FPrevState: TcxLookAndFeelData;
    FSystemPaletteChangedNotifier: TcxSystemPaletteChangedNotifier;
    FOnChanged: TcxLookAndFeelChangedEvent;
    function GetActiveStyle: TcxLookAndFeelStyle;
    function GetKind: TcxLookAndFeelKind;
    function GetMasterLookAndFeel: TcxLookAndFeel;
    function GetNativeStyle: Boolean;
    function GetPainter: TcxCustomLookAndFeelPainterClass;
    function GetSkinName: TdxSkinName;
    procedure SetAssignedValues(Value: TcxLookAndFeelValues);
    procedure SetKind(Value: TcxLookAndFeelKind);
    procedure SetMasterLookAndFeel(Value: TcxLookAndFeel);
    procedure SetNativeStyle(Value: Boolean);
    procedure SetPainter(Value: TcxCustomLookAndFeelPainterClass);
    procedure SetSkinName(const Value: TdxSkinName);

    procedure CheckStateChanges;
    function GetDefaultKind: TcxLookAndFeelKind;
    function GetDefaultNativeStyle: Boolean;
    function GetDefaultSkinName: string;
    function GetDefaultSkinPainter: TcxCustomLookAndFeelPainterClass;
    function IsKindStored: Boolean;
    function IsNativeStyleStored: Boolean;
    function IsSkinNameStored: Boolean;
    procedure ReadSkinName(Reader: TReader);
    procedure SaveState;
    procedure WriteSkinName(Writer: TWriter);

    { IcxLookAndFeelNotificationListener }
    function GetObject: TObject;
    procedure MasterLookAndFeelDestroying(Sender: TcxLookAndFeel);
    { IcxLookAndFeelPainterListener }
    procedure PainterChanged(APainter: TcxCustomLookAndFeelPainterClass);
  protected
    procedure Changed(AChangedValues: TcxLookAndFeelValues);
    procedure DefineProperties(Filer: TFiler); override;
    function InternalGetKind: TcxLookAndFeelKind; virtual;
    function InternalGetNativeStyle: Boolean; virtual;
    function InternalGetSkinName: string; virtual;
    function InternalGetSkinPainter: TcxCustomLookAndFeelPainterClass; virtual;
    function IsVisualSkinAvailable(const ASkinName: string;
      out Painter: TcxCustomLookAndFeelPainterClass): Boolean; virtual;
    procedure MasterLookAndFeelChanged(Sender: TcxLookAndFeel;
      AChangedValues: TcxLookAndFeelValues);
    procedure NotifyChanged;
    procedure SystemPaletteChanged; virtual;
  public
    constructor Create(AOwner: TPersistent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure AddChangeListener(AListener: IcxLookAndFeelNotificationListener);
    function GetAvailablePainter(ANeededThemedObjectType:
      TdxThemedObjectType): TcxCustomLookAndFeelPainterClass; overload;
    function GetAvailablePainter(ANeededThemedObjectTypes:
      TdxThemedObjectTypes = []): TcxCustomLookAndFeelPainterClass; overload;
    procedure Refresh;
    procedure RemoveChangeListener(AListener: IcxLookAndFeelNotificationListener);
    procedure Reset;
    procedure SetStyle(Value: TcxLookAndFeelStyle);
    property ActiveStyle: TcxLookAndFeelStyle read GetActiveStyle;
    property MasterLookAndFeel: TcxLookAndFeel read GetMasterLookAndFeel write SetMasterLookAndFeel;
    property Painter: TcxCustomLookAndFeelPainterClass read GetPainter write SetPainter;
    property SkinPainter: TcxCustomLookAndFeelPainterClass read FSkinPainter write FSkinPainter; 
    property OnChanged: TcxLookAndFeelChangedEvent read FOnChanged write FOnChanged;
  published
    property AssignedValues: TcxLookAndFeelValues read FAssignedValues write SetAssignedValues stored False;
    property Kind: TcxLookAndFeelKind read GetKind write SetKind stored IsKindStored;
    property NativeStyle: Boolean read GetNativeStyle write SetNativeStyle stored IsNativeStyleStored;
    property SkinName: TdxSkinName read GetSkinName write SetSkinName stored IsSkinNameStored;
  end;

  { TcxLookAndFeelController }

  TcxLookAndFeelController = class(TComponent, IcxLookAndFeelNotificationListener)
  private
    function GetKind: TcxLookAndFeelKind;
    function GetNativeStyle: Boolean;
    function GetSkinName: TdxSkinName;
    function IsSkinNameStored: Boolean;
    procedure SetKind(Value: TcxLookAndFeelKind);
    procedure SetNativeStyle(Value: Boolean);
    procedure SetSkinName(const Value: TdxSkinName);
    procedure Modified;
    { IcxLookAndFeelNotificationListener }
    function GetObject: TObject;
  protected
    procedure MasterLookAndFeelChanged(Sender: TcxLookAndFeel; AChangedValues: TcxLookAndFeelValues); virtual;
    procedure MasterLookAndFeelDestroying(Sender: TcxLookAndFeel); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Kind: TcxLookAndFeelKind read GetKind write SetKind default cxDefaultLookAndFeelKind;
    property NativeStyle: Boolean read GetNativeStyle write SetNativeStyle default cxDefaultLookAndFeelNativeStyle;
    property SkinName: TdxSkinName read GetSkinName write SetSkinName stored IsSkinNameStored;
  end;

  { TcxSystemPaletteChangedNotifier }

  TcxSystemPaletteChangedEvent = procedure of object;

  TcxSystemPaletteChangedNotifier = class
  private
    FIsPrimary: Boolean;
    FOnSystemPaletteChanged: TcxSystemPaletteChangedEvent;
  protected
    procedure DoChanged; virtual;
  public
    constructor Create(AIsPrimary: Boolean = False); virtual;
    destructor Destroy; override;
    property OnSystemPaletteChanged: TcxSystemPaletteChangedEvent
      read FOnSystemPaletteChanged write FOnSystemPaletteChanged;
  end;

  TdxClassSupportsSkinProc = function(AClass: TPersistent): Boolean;

function RootLookAndFeel: TcxLookAndFeel;
procedure SetControlLookAndFeel(AControl: TWinControl; AMasterLookAndFeel: TcxLookAndFeel); overload;
procedure SetControlLookAndFeel(AControl: TWinControl; AKind: TcxLookAndFeelKind;
  ANativeStyle: Boolean); overload;

var
  ClassSupportsSkinProc: TdxClassSupportsSkinProc;

implementation

uses
{$IFDEF WIN32}
  Windows,
{$ENDIF}
  cxControls;

const
  LookAndFeelValueAll = [lfvKind, lfvNativeStyle, lfvSkinName];
  LookAndFeelPainterMap: array[TcxLookAndFeelKind] of TcxCustomLookAndFeelPainterClass = (
    TcxFlatLookAndFeelPainter,
    TcxStandardLookAndFeelPainter,
    TcxUltraFlatLookAndFeelPainter,
    TcxOffice11LookAndFeelPainter
  );
  LookAndFeelStyleMap: array[TcxLookAndFeelKind] of TcxLookAndFeelStyle =
    (lfsFlat, lfsStandard, lfsUltraFlat, lfsOffice11);
  LookAndFeelKindMap: array[TcxLookAndFeelStyle] of TcxLookAndFeelKind =
    (lfFlat, lfStandard, lfUltraFlat, lfStandard, lfOffice11);

type
  { TcxSystemPaletteChangedListener }

  TcxSystemPaletteChangedListener = class
  private
    FNotifierList: TList;
    FPrimaryNotifierList: TList;
    FWindowHandle: TcxHandle;
    procedure DoChange;
    procedure WndProc(var Msg: TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddNotifier(ANotifier: TcxSystemPaletteChangedNotifier;
      AIsPrimary: Boolean);
    procedure RemoveNotifier(ANotifier: TcxSystemPaletteChangedNotifier;
      AIsPrimary: Boolean);
  end;

var
  FLookAndFeelControllerCount: Integer;
  FRootLookAndFeel: TcxLookAndFeel;
  FSystemPaletteChangedListener: TcxSystemPaletteChangedListener;
  FSystemPaletteChangedListenerRefCount: Integer;

procedure SetControlLookAndFeel(AControl: TWinControl; AMasterLookAndFeel: TcxLookAndFeel);
var
  AIntf: IcxLookAndFeelContainer;
  I: Integer;
begin
  if Supports(AControl, IcxLookAndFeelContainer, AIntf) then
    AIntf.GetLookAndFeel.MasterLookAndFeel := AMasterLookAndFeel;
  for I := 0 to AControl.ControlCount - 1 do
    if AControl.Controls[I] is TWinControl then
      SetControlLookAndFeel(TWinControl(AControl.Controls[I]), AMasterLookAndFeel);
end;

procedure SetControlLookAndFeel(AControl: TWinControl; AKind: TcxLookAndFeelKind;
  ANativeStyle: Boolean);
var
  AIntf: IcxLookAndFeelContainer;
  I: Integer;
begin
  if Supports(AControl, IcxLookAndFeelContainer, AIntf) then
    with AIntf.GetLookAndFeel do
    begin
      Kind := AKind;
      NativeStyle := ANativeStyle;
    end;
  for I := 0 to AControl.ControlCount - 1 do
    if AControl.Controls[I] is TWinControl then
      SetControlLookAndFeel(TWinControl(AControl.Controls[I]), AKind, ANativeStyle);
end;  

procedure AddRefSystemPaletteChangedListener;
begin
  if FSystemPaletteChangedListenerRefCount = 0 then
    FSystemPaletteChangedListener := TcxSystemPaletteChangedListener.Create;
  Inc(FSystemPaletteChangedListenerRefCount);
end;

procedure ReleaseRefSystemPaletteChangedListener;
begin
  Dec(FSystemPaletteChangedListenerRefCount);
  if FSystemPaletteChangedListenerRefCount = 0 then
    FreeAndNil(FSystemPaletteChangedListener);
end;

function RootLookAndFeel: TcxLookAndFeel;
begin
  Result := FRootLookAndFeel;
end;

{ TcxSystemPaletteChangedListener }

constructor TcxSystemPaletteChangedListener.Create;
begin
  inherited Create;
  CreateOffice11Colors;
  FWindowHandle := AllocateHWnd(WndProc);
  FNotifierList := TList.Create;
  FPrimaryNotifierList := TList.Create;
end;

destructor TcxSystemPaletteChangedListener.Destroy;
begin
  FreeAndNil(FPrimaryNotifierList);
  FreeAndNil(FNotifierList);
  DeallocateHWnd(FWindowHandle);