tebkgrnd.pas

delphi2007界面效果控件源码

unit teBkgrnd;

interface

{$INCLUDE teDefs.inc}

uses
  Windows, Messages, SysUtils, Classes, Forms, Graphics, Controls,
  teRender;

{$ifndef TE_NOHLP}
const
  CM_TEBASE            = CM_BASE   + 532;
  CM_TEGETBKGNDOPTIONS = CM_TEBASE +   0;
{$endif TE_NOHLP}

type
  TFCPictureMode = (fcpmCenter, fcpmCenterStretch, fcpmStretch, fcpmTile,
    fcpmZoom, fcpmTopLeft);
  TFCTranslucency = 0..255;

  TFCBackgroundOptions = class(TPersistent)
  private
    FControl: TControl;
    FChildBkOptions: TList;
    FParent: TFCBackgroundOptions;
    FOpaque,
    FParentOpaque,
    FParentPicture: Boolean;
    FPicture: TPicture;
    FPictureVisible: Boolean;
    FPictureMode: TFCPictureMode;
    FPictureTranspColor: TColor;
    FParentBkgrndForm: Boolean;
    FBkgrndForm: TCustomForm;
    FBkgrndFormVisible: Boolean;
    FParentGlass: Boolean;
    FGlassColor: TColor;
    FGlassTranslucency: TFCTranslucency;
    FGlassVisible,
    OpaqueActive,
    BkFormActive,
    GlassActive,
    PictureActive,
    FThemesDisabled: Boolean;
    
    FOnChange: TNotifyEvent;

    function GetChildBkOptions(Index: Integer): TFCBackgroundOptions;

    procedure Insert(Child: TFCBackgroundOptions);
    procedure Remove(Child: TFCBackgroundOptions);
    procedure SetControl(const Value: TControl);

    function  GetOpaque: Boolean;
    procedure SetOpaque(Value: Boolean);
    function  GetParentOpaque: Boolean;
    procedure SetParentOpaque(const Value: Boolean);
    function  IsOpaqueActive: Boolean;
    function  IsBkFormActive: Boolean;
    function  IsGlassActive: Boolean;
    function  XRayActive(PictureBkOptions: TFCBackgroundOptions;
      R: TRect): Boolean;
    function  IsPictureActive: Boolean;
    function  GetParentPicture: TFCBackgroundOptions;
    procedure SetParentPicture(const Value: Boolean);
    function  IsPictureStored: Boolean;
    function  GetPicture: TPicture;
    procedure SetPicture(const Value: TPicture);
    procedure SetPictureVisible(Value: Boolean);
    function  GetPictureMode: TFCPictureMode;
    procedure SetPictureMode(Value: TFCPictureMode);
    function  GetPictureTranspColor: TColor;
    procedure SetPictureTranspColor(Value: TColor);

    function  GetParentBkgrndForm: TFCBackgroundOptions;
    procedure SetParentBkgrndForm(const Value: Boolean);
    function  GetBkgrndForm: TCustomForm;
    procedure SetBkgrndFormVisible(Value: Boolean);

    function  GetParentGlass: TFCBackgroundOptions;
    procedure SetParentGlass(const Value: Boolean);
    function  IsGlassStored: Boolean;
    function  GetGlassColor: TColor;
    procedure SetGlassColor(const Value: TColor);
    function  GetGlassTranslucency: TFCTranslucency;
    procedure SetGlassTranslucency(const Value: TFCTranslucency);
    procedure SetGlassVisible(Value: Boolean);
    {$ifdef D7UP}
    procedure SetThemesDisabled(const Value: Boolean);
    {$endif D7UP}
  protected
    procedure Changed;
    procedure OpaqueChanged(Sender: TObject);
    procedure PictureChanged(Sender: TObject);
    procedure PicChanged(Sender: TObject; Propagate: Boolean);
    procedure BkgrndFormChanged(Sender: TObject; Propagate: Boolean);
    procedure GlassChanged(Sender: TObject; Propagate: Boolean);
    function  GlassTranslucencyToUse: TFCTranslucency;

    property ChildBkOptions[Index: Integer]: TFCBackgroundOptions read GetChildBkOptions;
  public
    constructor Create; virtual;
    destructor  Destroy; override;

    procedure Assign(Source: TPersistent); override;
    procedure ControlChanged(Sender: TObject);
    procedure DrawBackGround(DC: HDC; DstBmp: TBitmap;
      R: TRect);
    function  GetPalette: HPalette;
    procedure SetBkgrndForm(Value: TCustomFormClass);
    function  IsActive: Boolean;

    property BkgrndForm: TCustomForm read GetBkgrndForm;
    property Control: TControl read FControl write SetControl;
    property Parent: TFCBackgroundOptions read FParent;
  published
    property Opaque: Boolean read GetOpaque write SetOpaque default True;
    property ParentOpaque: Boolean read FParentOpaque write SetParentOpaque default False;
    property BkgrndFormVisible: Boolean read FBkgrndFormVisible write SetBkgrndFormVisible default True;
    property ParentBkgrndForm: Boolean read FParentBkgrndForm write SetParentBkgrndForm default False;
    property ParentPicture: Boolean read FParentPicture write SetParentPicture default False;
    property Picture: TPicture read GetPicture write SetPicture stored IsPictureStored;
    property PictureMode: TFCPictureMode read GetPictureMode write SetPictureMode stored IsPictureStored default fcpmTile;
    property PictureTranspColor: TColor read GetPictureTranspColor write SetPictureTranspColor stored IsPictureStored default clNone;
    property PictureVisible: Boolean read FPictureVisible write SetPictureVisible default True;
    property GlassColor: TColor read GetGlassColor write SetGlassColor stored IsGlassStored default clBlack;
    property GlassTranslucency: TFCTranslucency read GetGlassTranslucency write SetGlassTranslucency stored IsGlassStored default 255;
    property GlassVisible: Boolean read FGlassVisible write SetGlassVisible default True;
    property ParentGlass: Boolean read FParentGlass write SetParentGlass default False;
    {$ifdef D7UP}
    property ThemesDisabled: Boolean read FThemesDisabled write SetThemesDisabled default False;
    {$endif D7UP}

    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  {$ifndef TE_NOHLP}
  function PictureRect(Pic: TGraphic; PictureMode: TFCPictureMode; Margin: Word;
    CtrlThis: TControl; CtrlOrg: TWinControl; var DrawRect: TRect): TRect;
  procedure DrawPicture(Pic: TGraphic; PictureMode: TFCPictureMode;
    PictureTranspColor: TColor; PicCtrl: TWinControl; Bmp: TBitmap; R: TRect;
    Margin: Word; Ctrl: TControl);
  function TEGetPictureModeDesc(PictureMode: TFCPictureMode): String;
  {$ifdef D7UP}
  function BEParentBackgroundPainted(Handle: HWND): Boolean;
  {$endif D7UP}
  {$endif TE_NOHLP}

implementation

uses
  {$ifdef D7UP}Themes, UxTheme, {$endif D7UP}
  teBlndWk, TypInfo, Math;

type
  TFCControl = class(TControl);
  TFCCustomForm = class(TCustomForm);

{$ifdef D7UP}
{$ifndef NoVCL}
var
  BEDrawParentBackgroundList: TList = nil;
{$endif NoVCL}
{$endif D7UP}

{ TFCBackgroundOptions }

constructor TFCBackgroundOptions.Create;
begin
  inherited Create;

  FChildBkOptions     := TList.Create;
  FOpaque             := True;
  FParentOpaque       := False;
  FParentBkgrndForm   := False;
  FBkgrndForm         := nil;
  FBkgrndFormVisible  := True;
  FParentPicture      := False;
  FPicture            := TPicture.Create;
  FPicture.OnChange   := PictureChanged;
  FPictureVisible     := True;
  FPictureMode        := fcpmTile;
  FPictureTranspColor := clNone;
  FParentGlass        := False;
  FGlassColor         := clBlack;
  FGlassTranslucency  := 255;
  FGlassVisible       := True;
  FThemesDisabled     := False;
end;

destructor TFCBackgroundOptions.Destroy;
begin
  if Assigned(Control)                            and
    (not(csDestroying in Control.ComponentState)) and
    IsActive then
    Changed;
    
  if Parent <> nil then
    Parent.Remove(Self);

  FPicture.Free;

  while FChildBkOptions.Count > 0 do
    Remove(TFCBackgroundOptions(FChildBkOptions[0]));
  FChildBkOptions.Free;

  inherited;
end;

procedure TFCBackgroundOptions.Assign(Source: TPersistent);
var
  aux: TFCBackgroundOptions;
begin
  if Source is TFCBackgroundOptions
  then
  begin
    aux := (Source as TFCBackgroundOptions);

    ParentOpaque := aux.ParentOpaque;
    if not ParentOpaque then
      Opaque := aux.Opaque;

    PictureVisible := aux.PictureVisible;
    ParentPicture  := aux.ParentPicture;
    if not ParentPicture then
    begin
      Picture.Assign(aux.Picture);
      PictureMode        := aux.PictureMode;
      PictureTranspColor := aux.PictureTranspColor;
    end;

    BkgrndFormVisible := aux.BkgrndFormVisible;
    ParentBkgrndForm  := aux.ParentBkgrndForm;
    if not ParentBkgrndForm then
    begin
      if Assigned(aux.BkgrndForm) then
        SetBkgrndForm(TCustomFormClass(aux.FBkgrndForm.ClassType));
    end;

    GlassVisible := aux.GlassVisible;
    ParentGlass  := aux.ParentGlass;
    if not ParentGlass then
    begin
      GlassColor        := aux.GlassColor;
      GlassTranslucency := aux.GlassTranslucency;
    end;
  end
  else inherited Assign(Source);
end;

procedure TFCBackgroundOptions.Insert(Child: TFCBackgroundOptions);
begin
  if Child <> nil then
  begin
    if Child.Parent <> nil then
      Child.Parent.Remove(Child);

    FChildBkOptions.Add(Child);
    Child.FParent := Self;
  end;
end;

procedure TFCBackgroundOptions.Remove(Child: TFCBackgroundOptions);
begin
  FChildBkOptions.Remove(Child);
  Child.FParent := nil;
end;

procedure TFCBackgroundOptions.Changed;

  procedure DoPaletteChange;
  var
    ParentForm: TCustomForm;
    Tmp: TGraphic;
  begin
    Tmp := Picture.Graphic;
    if IsPictureActive                            and
      (not (csLoading in Control.ComponentState)) and
      (Tmp <> nil)                                and
      (Tmp.PaletteModified)                       then
    begin
      if Tmp.Palette = 0
      then Tmp.PaletteModified := False
      else
      begin
        ParentForm := GetParentForm(Control);
        if Assigned(ParentForm) and ParentForm.Active and ParentForm.HandleAllocated then
        begin
          SendMessage(ParentForm.Handle, wm_QueryNewPalette, 0, 0);
          Tmp.PaletteModified := False;
        end;
      end;
    end;
  end;

begin
  if Assigned(Control) then
  begin
    DoPaletteChange;
    Control.Invalidate;
  end;
  if Assigned(OnChange) then
    OnChange(Self);
end;

function TFCBackgroundOptions.GetPalette: HPalette;
begin
  Result := 0;
  if FPicture.Graphic <> nil then
    Result := FPicture.Graphic.Palette;
end;

function TFCBackgroundOptions.GetChildBkOptions(
  Index: Integer): TFCBackgroundOptions;
begin
   Result := TFCBackgroundOptions(FChildBkOptions.Items[Index]);
end;

procedure TFCBackgroundOptions.SetControl(const Value: TControl);

  function GetParentBkOptions(Ctrl: TControl): TFCBackgroundOptions;
  type
    TFCGetBackgroundOptions = function: TFCBackgroundOptions of object;
  var
    Info: PPropInfo;
    CtrlParent: TWinControl;
  begin
    Result := nil;
    if Ctrl <> nil
    then
    begin
      if Ctrl.Parent <> nil
      then CtrlParent := Ctrl.Parent
      else
      begin
        CtrlParent := FindControl((Ctrl as TWinControl).ParentWindow);
        if CtrlParent = nil then
        begin
          if(Ctrl is TForm) and (TForm(Ctrl).FormStyle = fsMDIChild) then
            CtrlParent := Application.MainForm;
        end;
      end;
    end
    else CtrlParent := nil;

    if CtrlParent <> nil then
    begin
      Info := GetPropInfo(CtrlParent.ClassInfo, 'BackgroundOptions');
      if(Info <> nil) and (Info^.PropType^^.Name <> 'TFCBackgroundOptions') then
        Info := nil;

      if Info = nil
      then
      begin
        Result := TFCBackgroundOptions(
          CtrlParent.Perform(CM_TEGETBKGNDOPTIONS, 0, 0));
      end
      else Result := TFCBackgroundOptions(GetOrdProp(CtrlParent, Info));

      if Result = nil then
        Result := GetParentBkOptions(CtrlParent);
    end;
  end;

  procedure CheckChildBkOptions(Ctrl: TWinControl);
  type
    TFCGetBackgroundOptions = function: TFCBackgroundOptions of object;
  var
    Info: PPropInfo;
    i: Integer;
    Child: TControl;
    BkOptions: TFCBackgroundOptions;
  begin
    for i:=0 to Ctrl.ControlCount-1 do
    begin
      Child := Ctrl.Controls[i];
      Info := GetPropInfo(Child.ClassInfo, 'BackgroundOptions');

      if Info = nil
      then
      begin
        if Child is TWinControl
        then BkOptions := TFCBackgroundOptions(
               (Child as TWinControl).Perform(CM_TEGETBKGNDOPTIONS, 0, 0))
        else BkOptions := TFCBackgroundOptions(
               Child.Perform(CM_TEGETBKGNDOPTIONS, 0, 0));
      end
      else
      begin
        BkOptions := TFCBackgroundOptions(GetOrdProp(Child, Info));
      end;

      if BkOptions <> nil
      then Insert(BkOptions)
      else
      begin
        if Child is TWinControl then
          CheckChildBkOptions(TWinControl(Child));
      end;
    end;
  end;

var
  ParentBkOptions: TFCBackgroundOptions;
begin
  if FControl <> Value then
  begin
    if Parent <> nil then
      Parent.Remove(Self);
    FControl := Value;
    ParentBkOptions := GetParentBkOptions(FControl);
    if ParentBkOptions <> nil then
      ParentBkOptions.Insert(Self);
    if FControl is TWinControl then
    begin
      while FChildBkOptions.Count > 0 do
        Remove(ChildBkOptions[0]);
      CheckChildBkOptions(TWinControl(FControl));
    end;
  end;
end;

function TFCBackgroundOptions.GetOpaque: Boolean;
begin
  Result := GetParentOpaque;
end;

procedure TFCBackgroundOptions.SetOpaque(Value: Boolean);
begin
  FParentOpaque := False;
  
  if FOpaque <> Value then
  begin
    FOpaque := Value;
    if Assigned(Control) then
      Control.Invalidate;
  end;
end;

function TFCBackgroundOptions.GetParentOpaque: Boolean;
begin
  Result := FOpaque;
  if ParentOpaque                      and
     Assigned(Parent)                  and
     Assigned(Control)                 and
     (Parent.Control = Control.Parent) then
    Result := Parent.GetParentOpaque;
end;

procedure TFCBackgroundOptions.SetParentOpaque(const Value: Boolean);
begin
  if FParentOpaque <> Value then
  begin
    FParentOpaque := Value;
    OpaqueChanged(Self);
  end;
end;

function TFCBackgroundOptions.GetParentPicture: TFCBackgroundOptions;
begin
  Result := Self;
  if ParentPicture and Assigned(Parent) then
    Result := Parent.GetParentPicture;
end;

function TFCBackgroundOptions.GetParentBkgrndForm: TFCBackgroundOptions;
begin
  Result := Self;
  if ParentBkgrndForm and Assigned(Parent) then
    Result := Parent.GetParentBkgrndForm;
end;

function TFCBackgroundOptions.GetParentGlass: TFCBackgroundOptions;
begin
  Result := Self;
  if ParentGlass and Assigned(Parent) then
    Result := Parent.GetParentGlass;
end;

procedure TFCBackgroundOptions.SetParentPicture(const Value: Boolean);
begin
  if FParentPicture <> Value then
  begin
    if Value then
      Picture.Graphic := nil;

    FParentPicture := Value;

    PicChanged(Self, True);
  end;
end;

procedure TFCBackgroundOptions.SetParentBkgrndForm(const Value: Boolean);
begin
  if FParentBkgrndForm <> Value then
  begin
    if Value then
    begin
      FBkgrndForm.Free;
      FBkgrndForm := nil;
    end;