sskinmanager.pas

AlphaControls是一个Delphi标准控件的集合

unit sSkinManager;
{$I sDefs.inc}

{$IFDEF DELPHI6UP}
{$WARN UNIT_PLATFORM OFF}
{$ENDIF}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  sConst, IniFiles, sMaskData, sGradient, sSkinMenus, jpeg;

type

  TsSkinManager = class;
  TsStoredSkin = class;

  TsSkinGeneral = class(TCollectionItem)
  private
    FName: string;
    FShowFocus: boolean;
    FFadingEnabled: boolean;
    FShadowEnabled: boolean;
    FShadowDontUse: boolean;
    FShadowTransparency: integer;

    FPaintingBevelWidth: integer;
    FShadowOffset: integer;
    FFadingIntervalIn: integer;
    FHotImagePercent: integer;
    FSelectionBorderWidth: integer;
    FPaintingTransparency: integer;
    FHotPaintingBevelWidth: integer;
    FShadowBlur: integer;
    FFadingIntervalOut: integer;
    FHotPaintingTransparency: integer;
    FFadingIterations: integer;
    FHotFontColor: string;
    FHotGradientPercent: integer;
    FGradientPercent: integer;
    FImagePercent: integer;
    FHotGradientData: string;
    FGradientData: string;
    FParentClassName: string;
    FPaintingColorBorderBottom: TColor;
    FHotPaintingColor: TColor;
    FSelectionColor: TColor;
    FShadowColor: TColor;
    FPaintingColor: TColor;
    FPaintingColorBorderTop: TColor;
    FPaintingBevel: TsControlBevel;
    FHotPaintingBevel: TsControlBevel;
    FSelectionBorderBevel: TsEditorBevel;
    FSectionName: string;
    FFontColor: string;
    FReservedBoolean: boolean;
    procedure SetName(const Value: string);
    procedure SetFadingEnabled(const Value: boolean);
    procedure SetFadingIntervalIn(const Value: integer);
    procedure SetFadingIntervalOut(const Value: integer);
    procedure SetFadingIterations(const Value: integer);
    procedure SetGradientData(const Value: string);
    procedure SetGradientPercent(const Value: integer);
    procedure SetHotGradientData(const Value: string);
    procedure SetHotGradientPercent(const Value: integer);
    procedure SetHotImagePercent(const Value: integer);
    procedure SetHotPaintingBevel(const Value: TsControlBevel);
    procedure SetHotPaintingBevelWidth(const Value: integer);
    procedure SetHotPaintingColor(const Value: TColor);
    procedure SetHotPaintingTransparency(const Value: integer);
    procedure SetImagePercent(const Value: integer);
    procedure SetPaintingBevel(const Value: TsControlBevel);
    procedure SetPaintingBevelWidth(const Value: integer);
    procedure SetPaintingColor(const Value: TColor);
    procedure SetPaintingColorBorderBottom(const Value: TColor);
    procedure SetPaintingColorBorderTop(const Value: TColor);
    procedure SetPaintingTransparency(const Value: integer);
    procedure SetParentClassName(const Value: string);
    procedure SetSelectionBorderBevel(const Value: TsEditorBevel);
    procedure SetSelectionBorderWidth(const Value: integer);
    procedure SetSelectionColor(const Value: TColor);
    procedure SetShadowBlur(const Value: integer);
    procedure SetShadowColor(const Value: TColor);
    procedure SetShadowDontUse(const Value: boolean);
    procedure SetShadowEnabled(const Value: boolean);
    procedure SetShadowOffset(const Value: integer);
    procedure SetShadowTransparency(const Value: integer);
    procedure SetShowFocus(const Value: boolean);
    procedure SetSectionName(const Value: string);
    procedure SetHotFontColor(const Value: string);
    procedure SetFontColor(const Value: string);
    procedure SetReservedBoolean(const Value: boolean);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property SectionName : string read FSectionName write SetSectionName;
    property ParentClassName : string read FParentClassName write SetParentClassName;
    property PaintingColor : TColor read FPaintingColor write SetPaintingColor;
    property PaintingBevel : TsControlBevel read FPaintingBevel write SetPaintingBevel;
    property PaintingBevelWidth : integer read FPaintingBevelWidth write SetPaintingBevelWidth;
    property ShadowBlur : integer read FShadowBlur write SetShadowBlur;
    property ShadowColor : TColor read FShadowColor write SetShadowColor;
    property ShadowDontUse : boolean read FShadowDontUse write SetShadowDontUse;
    property ShadowEnabled : boolean read FShadowEnabled write SetShadowEnabled;
    property ReservedBoolean : boolean read FReservedBoolean write SetReservedBoolean;
    property ShadowOffset : integer read FShadowOffset write SetShadowOffset;
    property ShadowTransparency : integer read FShadowTransparency write SetShadowTransparency;
    property FontColor : string read FFontColor write SetFontColor;
    property HotFontColor : string read FHotFontColor write SetHotFontColor;
    property PaintingTransparency : integer read FPaintingTransparency write SetPaintingTransparency;
    property GradientPercent : integer read FGradientPercent write SetGradientPercent;
    property GradientData : string read FGradientData write SetGradientData;
    property ImagePercent : integer read FImagePercent write SetImagePercent;
    property ShowFocus : boolean read FShowFocus write SetShowFocus;
    property FadingEnabled : boolean read FFadingEnabled write SetFadingEnabled;
    property FadingIntervalIn : integer read FFadingIntervalIn write SetFadingIntervalIn;
    property FadingIntervalOut : integer read FFadingIntervalOut write SetFadingIntervalOut;
    property FadingIterations : integer read FFadingIterations write SetFadingIterations;
    property HotPaintingColor : TColor read FHotPaintingColor write SetHotPaintingColor;
    property HotPaintingTransparency : integer read FHotPaintingTransparency write SetHotPaintingTransparency;
    property HotPaintingBevel : TsControlBevel read FHotPaintingBevel write SetHotPaintingBevel;
    property HotPaintingBevelWidth : integer read FHotPaintingBevelWidth write SetHotPaintingBevelWidth;
    property HotGradientPercent : integer read FHotGradientPercent write SetHotGradientPercent;
    property HotGradientData : string read FHotGradientData write SetHotGradientData;
    property HotImagePercent : integer read FHotImagePercent write SetHotImagePercent;
    property PaintingColorBorderTop : TColor read FPaintingColorBorderTop write SetPaintingColorBorderTop;
    property PaintingColorBorderBottom : TColor read FPaintingColorBorderBottom write SetPaintingColorBorderBottom;
    property SelectionBorderBevel : TsEditorBevel read FSelectionBorderBevel write SetSelectionBorderBevel;
    property SelectionBorderWidth : integer read FSelectionBorderWidth write SetSelectionBorderWidth;
    property SelectionColor : TColor read FSelectionColor write SetSelectionColor;
    property Name : string read FName write SetName;
  end;

  TsSkinGenerals = class(TCollection)
  private
    FOwner: TsStoredSkin;
    function GetItem(Index: Integer): TsSkinGeneral;
    procedure SetItem(Index: Integer; Value: TsSkinGeneral);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TsStoredSkin);
    destructor Destroy; override;
    property Items[Index: Integer]: TsSkinGeneral read GetItem write SetItem; default;
  end;

  TsSkinImage = class(TCollectionItem)
  private
    FName: string;
    FImage: TBitmap;
    FClassName: string;
    FPropertyName: string;
    procedure SetName(const Value: string);
    procedure SetImage(const Value: TBitmap);
    procedure SetClassName(const Value: string);
    procedure SetPropertyName(const Value: string);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property SectionName : string read FClassName write SetClassName;
    property Image : TBitmap read FImage write SetImage;
    property Name : string read FName write SetName;
    property PropertyName : string read FPropertyName write SetPropertyName;
  end;

  TsSkinPattern = class(TCollectionItem)
  private
    FName: string;
    FImage: TJpegImage;
    FClassName: string;
    FPropertyName: string;
    procedure SetName(const Value: string);
    procedure SetImage(const Value: TJpegImage);
    procedure SetClassName(const Value: string);
    procedure SetPropertyName(const Value: string);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
  published
    property SectionName : string read FClassName write SetClassName;
    property Image : TJpegImage read FImage write SetImage;
    property Name : string read FName write SetName;
    property PropertyName : string read FPropertyName write SetPropertyName;
  end;

  TsSkinImages = class(TCollection)
  private
    FOwner: TsStoredSkin;
    function GetItem(Index: Integer): TsSkinImage;
    procedure SetItem(Index: Integer; Value: TsSkinImage);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TsStoredSkin);
    destructor Destroy; override;
    property Items[Index: Integer]: TsSkinImage read GetItem write SetItem; default;
  end;

  TsSkinPatterns = class(TCollection)
  private
    FOwner: TsStoredSkin;
    function GetItem(Index: Integer): TsSkinPattern;
    procedure SetItem(Index: Integer; Value: TsSkinPattern);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TsStoredSkin);
    destructor Destroy; override;
    property Items[Index: Integer]: TsSkinPattern read GetItem write SetItem; default;
  end;

  TsStoredSkin = class(TCollectionItem)
  private
    FImages: TsSkinImages;
    FName: string;
    FGeneralData: TsSkinGenerals;
    FPatterns: TsSkinPatterns;
    procedure SetImages(const Value: TsSkinImages);
    procedure SetName(const Value: string);
    procedure SetGeneralData(const Value: TsSkinGenerals);
    procedure SetPatterns(const Value: TsSkinPatterns);
  protected
  public
    procedure Assign(Source: TPersistent); override;
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure LoadSkin(sf : TMemIniFile);
    procedure LoadFromIni(gd : TsSkinGenerals; sf: TMemIniFile);
  published
    property Name : string read FName write SetName;
    property GeneralData : TsSkinGenerals read FGeneralData write SetGeneralData;
    property Images : TsSkinImages read FImages write SetImages;
    property Patterns : TsSkinPatterns read FPatterns write SetPatterns;
  end;

  TsStoredSkins = class(TCollection)
  private
    FOwner: TsSkinManager;
    function GetItem(Index: Integer): TsStoredSkin;
    procedure SetItem(Index: Integer; Value: TsStoredSkin);
  protected
    function GetOwner: TPersistent; override;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TsSkinManager);
    destructor Destroy; override;
    property Items[Index: Integer]: TsStoredSkin read GetItem write SetItem; default;
  end;

  TsSkinManager = class(TComponent)
  private
    FGroupIndex: integer;
    FSkinName: TsSkinName;
    FSkinDirectory: TsDirectory;
    FActive: boolean;
    FBuiltInSkins: TsStoredSkins;
    FSkinableMenus: TsSkinableMenus;
    FOnAfterChange: TNotifyEvent;
    FOnBeforeChange: TNotifyEvent;
    procedure SetSkinName(const Value: TsSkinName);
    procedure SetSkinDirectory(const Value: string);
    procedure SetActive(const Value: boolean);
    procedure SetBuiltInSkins(const Value: TsStoredSkins);
  protected
    procedure SendNewSkin;
    procedure SendRemoveSkin;
  public
    ParentForm : TCustomForm;
    function ChangeImageInSkin(SkinSection, PropName, FileName : string) : boolean;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AfterConstruction; override;
    procedure Loaded; override;
    function GetFullskinDirectory : string;
    function GetSkinNames(sl: TStrings) : string;
    function GetExternalSkinNames(sl: TStrings) : string;
    procedure GetSkinSections(sl: TStrings);
    procedure ExtractInternalSkin(NameOfSkin, DestDir : string);
    procedure  ExtractByIndex(Index : integer; DestDir : string);
    procedure SaveToIni(Index : integer; sf : TMemIniFile);

    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure UpdateSkin;
    procedure UpdateSkinSection(SectionName : string);
    property GroupIndex : integer read FGroupIndex write FGroupIndex;
    property SkinableMenus : TsSkinableMenus read FSkinableMenus write FSkinableMenus;
  published
    property Active : boolean read FActive write SetActive default True;
    property InternalSkins : TsStoredSkins read FBuiltInSkins write SetBuiltInSkins;
    property SkinDirectory : TsDirectory read FSkinDirectory write SetSkinDirectory;
    property SkinName : TsSkinName read FSkinName write SetSkinName;
    property OnAfterChange : TNotifyEvent read FOnAfterChange write FOnAfterChange;
    property OnBeforeChange : TNotifyEvent read FOnBeforeChange write FOnBeforeChange;
  end;

implementation

uses sMessages, sStyleSimply, sUtils,
  sStoreUtils,
  sVclUtils, sDefaults, menus, sSkinProps, FileCtrl;

{ TsSkinManager }

procedure TsSkinManager.AfterConstruction;
begin
  inherited;
  ParentForm := GetOwnerForm(Self);
end;

function TsSkinManager.ChangeImageInSkin(SkinSection, PropName, FileName: string): boolean;
var
  i, l, j : integer;
  s : string;
begin
  Result := False;
  if not sSkinData.Active then Exit;
  if (SkinSection = '') or (PropName='') or not FileExists(FileName) then Exit;

  s := UpperCase(PropName);
  if (s = PatternFile) or ( s = HotPatternFile) then begin
    if pos('.BMP', UpperCase(FileName)) > 0 then begin
      l := Length(ma);
      if l > 0 then begin
        for i := 0 to l - 1 do begin
          if (UpperCase(ma[i].PropertyName) = s) and
               (UpperCase(ma[i].ClassName) = UpperCase(skinSection))  then begin
            ma[i].Bmp.LoadFromFile(FileName);
            Result := True;
            Break;
          end;
        end;
      end;

      if not Result then begin
        l := Length(ma) + 1;
        SetLength(ma, l);
        ma[l - 1].PropertyName := '';
        ma[l - 1].ClassName := '';
        try
          ma[l - 1].Bmp := TBitmap.Create;
          ma[l - 1].Bmp.LoadFromFile(FileName);
        finally
          ma[l - 1].PropertyName := s;
          ma[l - 1].ClassName := UpperCase(skinSection);
        end;
        if ma[l - 1].Bmp.Width < 1 then begin
          FreeAndNil(ma[l - 1].Bmp);
          SetLength(ma, l - 1);
        end;

        l := Length(pa);
        if l > 0 then begin
          for i := 0 to l - 1 do begin
            if (UpperCase(pa[i].PropertyName) = s) and
                 (UpperCase(pa[i].ClassName) = UpperCase(skinSection))  then begin
              FreeAndNil(pa[i].Img);
              for  j := i to l - 2 do begin
                pa[j].ClassName := pa[j + 1].ClassName;
                pa[j].PropertyName := pa[j + 1].PropertyName;
                pa[j].Img := pa[j + 1].Img;
              end;
              SetLength(pa, l - 1);
              Break;
            end;
          end;
        end;
        Result := True;
      end;
    end
    else begin
      l := Length(pa);
      if l > 0 then begin
        for i := 0 to l - 1 do begin
          if (UpperCase(pa[i].PropertyName) = s) and
               (UpperCase(pa[i].ClassName) = UpperCase(skinSection))  then begin
            pa[i].Img.LoadFromFile(FileName);
            Result := True;
            Break;
          end;
        end;
      end;
      if not Result then begin
        l := Length(pa) + 1;
        SetLength(pa, l);
        pa[l - 1].PropertyName := '';
        pa[l - 1].ClassName := '';
        try
          pa[l - 1].Img := TJpegImage.Create;
          pa[l - 1].Img.LoadFromFile(FileName);
        finally
          pa[l - 1].PropertyName := s;
          pa[l - 1].ClassName := UpperCase(SkinSection);
        end;
        if pa[l - 1].Img.Width < 1 then begin
          FreeAndNil(pa[l - 1].Img);
          SetLength(pa, l - 1);
        end;
        l := Length(ma);
        if l > 0 then begin
          for i := 0 to l - 1 do begin
            if (UpperCase(ma[i].PropertyName) = s) and
                 (UpperCase(ma[i].ClassName) = UpperCase(skinSection))  then begin