cxstyles.pas

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

{********************************************************************}
{                                                                    }
{           Developer Express Visual Component Library               }
{           Express Cross Platform Library classes                   }
{                                                                    }
{           Copyright (c) 2000-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 EXPRESSCROSSPLATFORMLIBRARY 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 cxStyles;

{$I cxVer.inc}

interface

uses
  Windows,
  SysUtils, Classes, Graphics, cxClasses, cxGraphics;

type
  TcxCustomStyle = class;
  TcxStyleRepository = class;
  TcxCustomStyles = class;
  TcxCustomStylesClass = class of TcxCustomStyles;

  { IcxStyleChangeListener }

  IcxStyleChangeListener = interface
  ['{E25A5395-C1E8-4311-A281-9575F79DE862}']
    procedure StyleChanged(AStyle: TcxCustomStyle);
    procedure StyleRemoved(AStyle: TcxCustomStyle);
  end;

  { TcxCustomStyle }

  TcxCustomStyle = class(TComponent)
  private
    FListeners: TList;
    FStyleRepository: TcxStyleRepository;
    function GetIndex: Integer;
    procedure SetStyleRepository(Value: TcxStyleRepository);
  protected
    procedure Changed; virtual;
    procedure ReadState(Reader: TReader); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BeforeDestruction; override;
    procedure AddListener(AListener: IcxStyleChangeListener); virtual;
    function GetParentComponent: TComponent; override;
    function HasParent: Boolean; override;
    procedure RemoveListener(AListener: IcxStyleChangeListener); virtual;
    procedure RestoreDefaults; virtual;
    procedure SetParentComponent(AParent: TComponent); override;
    property Index: Integer read GetIndex;
    property StyleRepository: TcxStyleRepository read FStyleRepository write SetStyleRepository;
  end;

  TcxCustomStyleSheet = class(TcxComponent)
  private
    FBuiltIn: Boolean;
    FCaption: string;
    FStyles: TcxCustomStyles;
    FStylesList: TList;
    FStyleRepository: TcxStyleRepository;
    function GetCaptionStored: Boolean;
    function GetCaption: string;
    function GetIndex: Integer;
    procedure SetCaption(const Value: String);
    procedure SetStyleRepository(Value: TcxStyleRepository);

    procedure ReadBuiltIn(AReader: TReader);
    procedure WriteBuiltIn(AWriter: TWriter);
  protected
    procedure DefineProperties(AFiler: TFiler); override;
    procedure DoStyleChanged(AIndex: Integer);
    procedure GetFakeComponentLinks(AList: TList); override;
    procedure ReadState(Reader: TReader); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AddStyles(AStyles: TcxCustomStyles);
    procedure Assign(Source: TPersistent); override;
    procedure CopyFrom(AStyleSheet: TcxCustomStyleSheet);
    class function GetStylesClass: TcxCustomStylesClass; virtual;
    function GetParentComponent: TComponent; override;
    function HasParent: Boolean; override;
    function GetStyles: TcxCustomStyles;
    procedure RemoveStyles(AStyles: TcxCustomStyles);
    procedure SetStyles(const Value: TcxCustomStyles);
    procedure SetParentComponent(AParent: TComponent); override;
    property BuiltIn: Boolean read FBuiltIn;
    property Index: Integer read GetIndex;
    property StyleRepository: TcxStyleRepository read FStyleRepository write SetStyleRepository;
  published
    property Caption: string read GetCaption write SetCaption stored GetCaptionStored;
  end;

  TcxCustomStyleClass = class of TcxCustomStyle;
  TcxCustomStyleSheetClass = class of TcxCustomStyleSheet;

  { TcxStyleRepository }

  TcxStyleRepository = class(TComponent)
  private
    FItems: TList;
    FPixelsPerInch: Integer;
    FScalable: Boolean;
    FStyleSheets: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): TcxCustomStyle;
    function GetStyleSheetCount: Integer;
    function GetStyleSheet(Index: Integer): TcxCustomStyleSheet;
    procedure ReadPixelsPerInch(Reader: TReader);
    procedure WritePixelsPerInch(Writer: TWriter);
  protected
    procedure AddItem(AItem: TcxCustomStyle);
    procedure AddStyleSheet(AStyleSheet: TcxCustomStyleSheet);
    procedure DefineProperties(Filer: TFiler); override;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function GetScaledValue(AValue: Integer): Integer;
    procedure RemoveItem(AItem: TcxCustomStyle);
    procedure RemoveStyleSheet(AStyleSheet: TcxCustomStyleSheet);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Clear;
    procedure ClearStyleSheets;
    function CreateItem(AStyleClass: TcxCustomStyleClass): TcxCustomStyle; virtual;
    function CreateItemEx(AStyleClass: TcxCustomStyleClass; AOwner: TComponent): TcxCustomStyle; virtual;
    function CreateStyleSheet(AStyleSheetClass: TcxCustomStyleSheetClass): TcxCustomStyleSheet; virtual;
    function CreateStyleSheetEx(AStyleSheetClass: TcxCustomStyleSheetClass; AOwner: TComponent): TcxCustomStyleSheet; virtual;
    function StyleIndexOf(AStyle: TcxCustomStyle): Integer;
    function StyleSheetIndexOf(AStyleSheet: TcxCustomStyleSheet): Integer;
    property Count: Integer read GetCount;
    property StyleSheetCount: Integer read GetStyleSheetCount;
    property Items[Index: Integer]: TcxCustomStyle read GetItem; default;
    property StyleSheets[Index: Integer]: TcxCustomStyleSheet read GetStyleSheet;
  published
    property Scalable: Boolean read FScalable write FScalable default False;
  end;

  { TcxCustomStyles }

  TcxCustomStylesItem = class
    Index: Integer;
    Item: TcxCustomStyle;
    constructor Create(AIndex: Integer; AItem: TcxCustomStyle);
  end;

  TcxCustomStyles = class(TcxInterfacedPersistent, IcxStyleChangeListener)
  private
    FDestroying: Boolean;
    FItems: TList;
    FStyleSheet: TcxCustomStyleSheet;
    FOwnerStyleSheet: TcxCustomStyleSheet;  // style sheet to which styles object is aggregated
    function GetCount: Integer;
    function GetItem(Index: Integer): TcxCustomStylesItem;
    procedure SetStyleSheet(const Value: TcxCustomStyleSheet);
  protected
    // IcxStyleChangeListener
    procedure StyleChanged(Sender: TcxCustomStyle);
    procedure StyleRemoved(Sender: TcxCustomStyle);

    procedure Changed(AIndex: Integer); virtual;
    procedure Clear;
    procedure Delete(AItemIndex: Integer);
    procedure DoChanged(AIndex: Integer); virtual;
    function Find(AIndex: Integer; var AItemIndex: Integer): Boolean;
    function GetValue(Index: Integer): TcxCustomStyle;
    procedure SetValue(Index: Integer; Value: TcxCustomStyle);

    property Count: Integer read GetCount;
    property Destroying: Boolean read FDestroying;
    property Items[Index: Integer]: TcxCustomStylesItem read GetItem;
    property OwnerStyleSheet: TcxCustomStyleSheet read FOwnerStyleSheet;
    property StyleSheet: TcxCustomStyleSheet read FStyleSheet write SetStyleSheet;
  public
    constructor Create(AOwner: TPersistent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function IsValidStyleSheet(AStyleSheet: TcxCustomStyleSheet): Boolean;
    procedure ResetStyles;
    property Values[Index: Integer]: TcxCustomStyle read GetValue write SetValue;
  end;

  { TcxStyle }

  TcxStyleValue = (svBitmap, svColor, svFont, svTextColor);
  TcxStyleValues = set of TcxStyleValue;

  TcxStyle = class(TcxCustomStyle)
  private
    FAssignedValues: TcxStyleValues;
    FBitmap: TBitmap;
    FColor: TColor;
    FFont: TFont;
    FTextColor: TColor;
    procedure SetAssignedValues(Value: TcxStyleValues);
    procedure SetBitmap(Value: TBitmap);
    procedure SetColor(Value: TColor);
    procedure SetFont(Value: TFont);
    procedure SetTextColor(Value: TColor);
    procedure BitmapChanged(Sender: TObject);
    procedure FontChanged(Sender: TObject);
    function IsBitmapStored: Boolean;
    function IsColorStored: Boolean;
    function IsFontStored: Boolean;
    function IsTextColorStored: Boolean;
  protected
    procedure ReadState(Reader: TReader); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure RestoreDefaults; override;
  published
    property AssignedValues: TcxStyleValues read FAssignedValues write SetAssignedValues default [];
    property Color: TColor read FColor write SetColor stored IsColorStored;
    property Bitmap: TBitmap read FBitmap write SetBitmap stored IsBitmapStored;
    property Font: TFont read FFont write SetFont stored IsFontStored;
    property TextColor: TColor read FTextColor write SetTextColor stored IsTextColorStored;
  end;

  TcxStyleGetName = function(AStyle: TcxStyle): string of object;

  { TcxStyles }

  TcxStyles = class(TcxCustomStyles, IcxFontListener)
  private
    FMaxDefaultViewParamsIndex: Integer;
  protected
    BitmapInViewParams: Boolean;
    { IcxFontListener }
    procedure IcxFontListener.Changed = DefaultFontChanged;
    procedure DefaultFontChanged(Sender: TObject; AFont: TFont);

    function GetValue(Index: Integer): TcxStyle;
    procedure SetValue(Index: Integer; Value: TcxStyle);
    procedure GetDefaultViewParams(Index: Integer; AData: TObject; out AParams: TcxViewParams); virtual;
    function IsDefaultFont(Index: Integer): Boolean; virtual;
    property MaxDefaultViewParamsIndex: Integer read FMaxDefaultViewParamsIndex;
  public
    function GetBitmap(Index: Integer): TBitmap;
    procedure GetViewParams(Index: Integer; AData: TObject; AStyle: TcxStyle; out AParams: TcxViewParams);

    property Count;
    property StyleSheet;
    property Values[Index: Integer]: TcxStyle read GetValue write SetValue;
  end;

//function GetDefaultStyleRepository: TcxStyleRepository;
function CombineParamsWithStyle(AStyle: TcxStyle;
  AHasValues: TcxStyleValues; var AParams: TcxViewParams): TcxStyleValues;
function UseStyle(AStyle: TcxStyle; AStyleValue: TcxStyleValue): Boolean;
procedure CreateStyleSheetStyles(ADestStyleSheet, ASourceStyleSheet: TcxCustomStyleSheet;
  AStyleGetName: TcxStyleGetName = nil);

procedure RegisterStyleSheetClass(AStyleSheetClass: TcxCustomStyleSheetClass);
procedure UnregisterStyleSheetClass(AStyleSheetClass: TcxCustomStyleSheetClass);
procedure GetRegisteredStyleSheetClasses(AList: TList);

procedure SaveStyleSheetsToIniFile(const AIniFileName: string; const AList: TList);
procedure LoadStyleSheetsFromIniFile(const AIniFileName: string;
  AStyleRepository: TcxStyleRepository; AStyleSheetClass: TcxCustomStyleSheetClass;
  const AStyleSheetNames: TStrings = nil; AOwner: TComponent = nil;
  const AStyleSheetList: TList = nil; AStyleGetName: TcxStyleGetName = nil);

implementation

uses
  Controls, TypInfo, IniFiles;

const
  BitmapCaption = 'Bitmap';
  DefaultValue = 'default';

function BinaryStreamToString(AStream: TMemoryStream): string;
begin
  SetLength(Result, AStream.Size * 2);
  BinToHex(AStream.Memory, PChar(Result), AStream.Size);
end;

procedure StringToBinaryStream(const S: string; AStream: TMemoryStream);
begin
  AStream.Position := 0;
  AStream.Size := Length(S) div 2;
  HexToBin(PChar(S), AStream.Memory, AStream.Size);
end;

function UseStyle(AStyle: TcxStyle; AStyleValue: TcxStyleValue): Boolean;
begin
  Result := (AStyle <> nil) and (AStyleValue in AStyle.AssignedValues);
end;

function VerifyBitmap(ABitmap: TBitmap): Boolean;
begin
  Result := (ABitmap.Width > 0) and (ABitmap.Height > 0);
end;

function CombineParamsWithStyle(AStyle: TcxStyle;
  AHasValues: TcxStyleValues; var AParams: TcxViewParams): TcxStyleValues;

  function CanSetStyleValue(AValue: TcxStyleValue;
    var ASetValues: TcxStyleValues): Boolean;
  begin
    Result := not (AValue in AHasValues) and (AValue in AStyle.AssignedValues);
    if Result then
      Include(ASetValues, AValue);
  end;

begin
  Result := AHasValues;
  if (AStyle = nil) or ([svBitmap..svTextColor] = AHasValues) or
    (csDestroying in AStyle.ComponentState) then Exit;
  if CanSetStyleValue(svColor, Result) then
    AParams.Color := AStyle.Color;
  if (AStyle.Font <> nil) and CanSetStyleValue(svFont, Result) then
    AParams.Font := AStyle.Font;
  if CanSetStyleValue(svTextColor, Result) then
    AParams.TextColor := AStyle.TextColor;
  if CanSetStyleValue(svBitmap, Result) then
    AParams.Bitmap := AStyle.Bitmap;
end;

{ TcxCustomStyle }

constructor TcxCustomStyle.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FListeners := TList.Create;
end;

destructor TcxCustomStyle.Destroy;
begin
  StyleRepository := nil;
  FreeAndNil(FListeners);
  inherited Destroy;
end;

procedure TcxCustomStyle.BeforeDestruction;

  procedure RemoveNotification;
  begin
    while FListeners.Count <> 0 do
      IcxStyleChangeListener(FListeners.Last).StyleRemoved(Self);
  end;

begin
  inherited BeforeDestruction;
  RemoveNotification;
end;

procedure TcxCustomStyle.AddListener(AListener: IcxStyleChangeListener);
begin
  if FListeners.IndexOf(Pointer(AListener)) = -1 then
    FListeners.Add(Pointer(AListener));
end;

function TcxCustomStyle.GetParentComponent: TComponent;
begin
  Result := StyleRepository;
end;

function TcxCustomStyle.HasParent: Boolean;
begin
  Result := StyleRepository <> nil;
end;

procedure TcxCustomStyle.RemoveListener(AListener: IcxStyleChangeListener);
begin
  if FListeners <> nil then
    FListeners.Remove(Pointer(AListener));
end;

procedure TcxCustomStyle.RestoreDefaults;
begin
end;

procedure TcxCustomStyle.SetParentComponent(AParent: TComponent);
begin
  if not (csLoading in ComponentState) then
    StyleRepository := AParent as TcxStyleRepository;
end;

procedure TcxCustomStyle.Changed;
var
  I: Integer;
begin
  for I := FListeners.Count - 1 downto 0 do