tetheme.pas

这个东西的功能很强大

procedure RemoveThemeNotification(AObject: TObject);

{ Use this procedure to make the theme available for ThemeEngine components }

function GetThemeClass(ClassName: string): TteThemeClass;
procedure RegisterTheme(Theme: TteThemeClass);

{ Use this routines to check theme's classes, subclasses, objects
  in CurrentTheme object }

function IsThemeAvailable(ATheme: TteTheme): boolean; overload;
function IsThemeAvailable(AThemeName: string): boolean; overload;

{ Themes I/O }

function LoadThemeFromFile(AFileName: string): TteTheme;
function LoadThemeFromStream(AStream: TStream): TteTheme;
procedure SaveThemeToFile(ATheme: TteTheme; AFileName: string);
procedure SaveThemeToStream(ATheme: TteTheme; AStream: TStream);

function GetThemeByFileName(FileName: string): TteThemeClass; overload;
function GetDialogFilter: string;

{ Persitent and simple property store }

type
  TtePropValue = integer;

procedure AddObjectToStore(AObject: TPersistent);
procedure RemoveObjectFromStore(AObject: TPersistent);
procedure AssignFromStoredObject(AObject: TPersistent);

procedure AddPropToStore(AObject: TObject; APropName: string; AValue: TtePropValue);
procedure RemovePropFromStore(AObject: TObject; APropName: string);
function GetPropFromStore(AObject: TObject; APropName: string): TtePropValue;

procedure BeforeWriteState(AObject: TComponent);
procedure AfterWriteState(AObject: TComponent);


type

  TteBackground = record
    Rect: TRect;
    ClipRect: TRect;
    Control: TControl;
    Parent: TControl;
  end;

  TteDrawControlBackground = function (Canvas: TCanvas;
    Background: TteBackground): boolean;

{ Use this routines for drawing control's background, if control
  have transparent part (like CheckBox) }

procedure DrawControlBackground(Control: TControl; DC: HDC); overload;
procedure DrawControlBackground(Control: TControl; Canvas: TCanvas); overload;
procedure DrawControlBackground(Control: HWnd; Canvas: TCanvas); overload;

{ Register third-party DrawControlBackground }

procedure RegisterDrawControlBackground(AClass: TClass; AFunc: TteDrawControlBackground);


implementation {===============================================================}


type

  PDrawBackgroundFuncRec = ^TDrawBackgroundFuncRec;
  TDrawBackgroundFuncRec = record
    FClass: TClass;
    FFunc: TteDrawControlBackground;
  end;

  TDrawCustomControlAccess = class(TCustomControl);
  
var
  DrawBackgroundFuncList: TList = nil;

procedure RegisterDrawControlBackground(AClass: TClass; AFunc: TteDrawControlBackground);
var
  R: PDrawBackgroundFuncRec;
begin
  if DrawBackgroundFuncList = nil then
    DrawBackgroundFuncList := TList.Create;

  New(R);
  R^.FClass := AClass;
  R^.FFunc := AFunc;
  DrawBackgroundFuncList.Add(R);
end;

procedure FreeDrawBackgroundFuncList;
var
  i: integer;
begin
  if DrawBackgroundFuncList <> nil then
  begin
    for i := 0 to DrawBackgroundFuncList.Count - 1 do
      Dispose(PDrawBackgroundFuncRec(DrawBackgroundFuncList[i]));
    DrawBackgroundFuncList.Free;
  end;
end;

function GetDrawBackgroundFunc(AParent: TControl): TteDrawControlBackground;
var
  i: integer;
begin
  Result := nil;
  if DrawBackgroundFuncList <> nil then
  begin
    for i := 0 to DrawBackgroundFuncList.Count - 1 do
      if AParent is PDrawBackgroundFuncRec(DrawBackgroundFuncList[i])^.FClass then
      begin
        Result := PDrawBackgroundFuncRec(DrawBackgroundFuncList[i])^.FFunc;
        Exit;
      end;
  end;
end;

{ Drawing }

procedure DrawControlBackground(Control: TControl; DC: HDC);
var
  P: TPoint;
  i, SaveIndex: Integer;
  Func: TteDrawControlBackground;
  B: TteBackground;
  Canvas: TCanvas;
  SaveState: TControlState;
  SaveParentDC: HDC;
  Buffer: TBitmap;
begin
  if Control = nil then Exit;
  if Control.Parent = nil then Exit;
  if (Control.Width <= 0) or (Control.Height <= 0) then Exit;
  if csPaintCopy in Control.ControlState then Exit;

  { Paint Owner Background }
  SaveIndex := SaveDC(DC);
  try
    P := Control.ClientOrigin;
    { Offset DC }
    Windows.ScreenToClient(Control.Parent.Handle, P);
    MoveWindowOrg(DC, -P.X, -P.Y);
    { Drawing }
    Func := GetDrawBackgroundFunc(Control.Parent);
    if @Func <> nil then
    begin
      { Draw using DrawXXXXBackground function }
      B.Rect := Control.BoundsRect;
      B.ClipRect := Control.BoundsRect;
      B.Control := Control;
      B.Parent := Control.Parent;

      Canvas := TCanvas.Create;
      try
        Canvas.Handle := DC;
        SaveState := Control.ControlState;
        Control.ControlState := Control.ControlState + [csPaintCopy];
        try
          Func(Canvas, B);
        finally
          Control.ControlState := SaveState;
        end;
        Canvas.Handle := 0;
      finally
        Canvas.Free;
      end;
    end
    else
    begin
      { Paint parent to DC }
      SaveState := Control.ControlState;
      Control.ControlState := Control.ControlState + [csPaintCopy];
      try
        if Control is TGraphicControl then
        begin
          { Need double buffering }
          Buffer := TBitmap.Create;
          Buffer.Width := Control.Width;
          Buffer.Height := Control.Height;

          if (Control.Parent is TCustomControl) then
          begin
            { CustomControl drawing }
            MoveWindowOrg(Buffer.Canvas.Handle, -P.X, -P.Y);
            SaveParentDC := TDrawCustomControlAccess(Control.Parent).Canvas.Handle;
            TDrawCustomControlAccess(Control.Parent).Canvas.Handle := Buffer.Canvas.Handle;
            TDrawCustomControlAccess(Control.Parent).Paint;
            TDrawCustomControlAccess(Control.Parent).Canvas.Handle := SaveParentDC;
            MoveWindowOrg(Buffer.Canvas.Handle, P.X, P.Y);
          end
          else
          begin
            { WinControl drawing }
            MoveWindowOrg(Buffer.Canvas.Handle, -P.X, -P.Y);
            Control.Parent.Perform(WM_ERASEBKGND, Buffer.Canvas.Handle, 0);
            Control.Parent.Perform(WM_PAINT, Buffer.Canvas.Handle, 0);
            MoveWindowOrg(Buffer.Canvas.Handle, P.X, P.Y);
          end;

          BitBlt(DC, P.X, P.Y, Buffer.Width, Buffer.Height,
            Buffer.Canvas.Handle, 0, 0, SRCCOPY);

          Buffer.Free;
        end
        else
        begin
          { WinControl drawing }
          if (Control.Parent is TCustomControl) then
          begin
            { CustomControl drawing }
            SaveParentDC := TDrawCustomControlAccess(Control.Parent).Canvas.Handle;
            TDrawCustomControlAccess(Control.Parent).Canvas.Handle := DC;
            TDrawCustomControlAccess(Control.Parent).Paint;
            TDrawCustomControlAccess(Control.Parent).Canvas.Handle := SaveParentDC;
          end
          else
          begin
            { WinControl drawing }
            Control.Parent.Perform(WM_ERASEBKGND, DC, 0);
            Control.Parent.Perform(WM_PAINT, DC, 0);
          end;
        end;
      finally
        Control.ControlState := SaveState;
      end;
    end;
    { Restore DC origin }
    MoveWindowOrg(DC, P.X, P.Y);
  finally
    RestoreDC(DC, SaveIndex);
  end;
end;

procedure DrawControlBackground(Control: TControl; Canvas: TCanvas);
begin
  DrawControlBackground(Control, Canvas.Handle);
end;

procedure DrawControlBackground(Control: HWnd; Canvas: TCanvas);
begin
end;

{ Standard control drawing }

function DrawGroupBoxBackground(Canvas: TCanvas;
  Background: TteBackground): boolean;
begin
  with Background do
  begin
    if Parent is TGroupBox then
    begin
      FillRect(Canvas, Rect, TGroupBox(Parent).Color);
      Result := true;
    end;
  end;
end;



constructor TteThemeManager.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FThemeList := TList.Create;
  FHookWindow := AllocateHWnd(HookWndProc);
{  if not (csDesigning in ComponentState) then
    CurrentTheme := TteTheme.Create;}
  FNotifies := TList.Create;
end;

destructor TteThemeManager.Destroy;
begin
  FNotifies.Free;
  if CurrentTheme <> nil then CurrentTheme.Free;
  CurrentTheme := nil;
  DeallocateHWnd(FHookWindow);
  FThemeList.Free;
  inherited Destroy;
end;

procedure TteThemeManager.RegisterTheme(Theme: TteThemeClass);
begin
  FThemeList.Add(Theme);
end;

function TteThemeManager.GetThemeClass(ClassName: string): TteThemeClass;
var
  i: integer;
begin
  for i := 0 to FThemeList.Count-1 do
    if TteThemeClass(FThemeList[i]).ClassName = ClassName then
    begin
      Result := TteThemeClass(FThemeList[i]);
      Exit;;
    end;

  Result := nil;
end;

procedure TteThemeManager.HookWndProc(var Message: TMessage);
begin
  case Message.Msg of
    WM_DISPLAYCHANGE, WM_SYSCOLORCHANGE{, WM_THEMECHANGED}:
      begin
        Broadcast(SNM_THEMEMESSAGE, SMP_REPAINT, 0);
      end;
  end;
  with Message do
    Result := DefWindowProc(FHookWindow, Msg, wParam, lParam);
end;

procedure TteThemeManager.Broadcast(Msg: Cardinal; WParam, LParam: integer);
var
  i: integer;
  M: TMessage;
begin
  M.Msg := Msg;
  M.WParam := WParam;
  M.LParam := LParam;
  M.Result := 0;
  if (wParam = SMP_REPAINT) then
    for i := 0 to FNotifies.Count - 1 do
    begin
      if (TObject(FNotifies[i]) is TControl) then
      begin
        if TControl(FNotifies[i]).Visible then // speedup
          TControl(FNotifies[i]).Perform(SNM_THEMEMESSAGE, WParam, LParam);
      end
      else
        TObject(FNotifies[i]).Dispatch(M);
    end
  else
    for i := 0 to FNotifies.Count - 1 do
    begin
      if TObject(FNotifies[i]) is TControl then
        TControl(FNotifies[i]).Perform(SNM_THEMEMESSAGE, WParam, LParam)
      else
        TObject(FNotifies[i]).Dispatch(M);
    end;
end;

procedure TteThemeManager.AddNotification(AObject: TObject);
var
  M: TMessage;
begin
  if FNotifies.IndexOf(AObject) = -1 then
  begin
    FNotifies.Add(AObject);
    { Send SNM_ThemeChange message }
    if IsThemeAvailable(CurrentTheme) then
    begin
      M.Msg := SNM_THEMEMESSAGE;
      M.WParam := SMP_APPLYTHEME;
      M.Result := 0;
      if AObject is TControl then
        TControl(AObject).Perform(SNM_THEMEMESSAGE, SMP_APPLYTHEME, 0)
      else
        AObject.Dispatch(M);
    end;
  end;
end;

procedure TteThemeManager.RemoveNotification(AObject: TObject);
begin
  FNotifies.Remove(AObject);
end;

function TteThemeManager.GetDialogFilter: string;
var
  i: integer;
  S, Filter, AllStr: string;
begin
  Result := '';
  AllStr := '';
  for i := 0 to FThemeList.Count - 1 do
  begin
    if TteThemeClass(FThemeList[i]).GetThemeOptions.CanStore then
    begin
      if Result <> '' then Result := Result + '|';
      Result := Result + TteThemeClass(FThemeList[i]).GetThemeOptions.DialogFilter;
      { Parse filter to make AllStr }
      Filter := TteThemeClass(FThemeList[i]).GetThemeOptions.DialogFilter;
      S := GetToken(Filter, ['|']);
      while S <> '' do
      begin
        { Parse only ext } 
        S := GetToken(Filter, ['|']);
        AllStr := AllStr + S + ';';
        { Skip filter name }
        S := GetToken(Filter, ['|']);
      end;
    end;
  end;
  if AllStr <> '' then
  begin
    SetLength(AllStr, Length(AllStr) - 1);
    Result := sAllFilter + ' (' + AllStr + ')|' + AllStr + '|' + Result;
  end;
end;

function TteThemeManager.GetThemeByFileName(FileName: string): TteThemeClass;
var
  i: integer;
begin
  Result := nil;
  for i := 0 to FThemeList.Count - 1 do
  begin
    if TteThemeClass(FThemeList[i]).GetThemeOptions.CanStore then
    begin
      if AnsiPos(AnsiLowerCase(ExtractFileExt(FileName)), AnsiLowerCase(TteThemeClass(FThemeList[i]).GetThemeOptions.DialogFilter)) > 0 then
      begin
        Result := TteThemeClass(FThemeList[i]);
        Exit;
      end;
    end;
  end;
end;

function TteThemeManager.LoadFromFile(AFileName: string): TteTheme;
var
  FStream: TFileStream;
  ResultThemeClass: TteThemeClass;
begin
  Result := nil;

  { Complete file name }
  if AFileName = '' then Exit;
  if not FileExists(AFileName) and (Length(AFileName) >= 2) then
  begin
    if AFileName[2] <> ':' then
    begin
      AFileName := ExtractFilePath(ParamStr(0)) + AFileName;
      if not FileExists(AFileName) then Exit;
    end
    else
      Exit;
  end;

  { Check file extension }
  ResultThemeClass := GetThemeByFileName(AFileName);
  if ResultThemeClass <> nil then
  begin
    { Use them LoadFromFile }
    Result := ResultThemeClass.Create;
    if not Result.LoadFromFile(AFileName) then
    begin
      Result.Free;
      Result := nil;
    end;
    Exit;
  end
  else
  begin
    { Use default them loading }
    FStream := TFileStream.Create(AFileName, fmOpenRead);
    try
      Result := LoadFromStream(FStream);
    finally
      FStream.Free;
    end;
  end;
end;

procedure TteThemeManager.SaveToFile(ATheme: TteTheme; AFileName: string);
begin
  if (ATheme <> nil) and (ATheme.GetThemeOptions.CanStore) then
    ATheme.SaveToFile(AFileName);
end;

function TteThemeManager.LoadFromStream(AStream: TStream): TteTheme;
var
  i: integer;
  SavePos: longint;
begin
  Result := nil;

  { Load theme from stream }
  SavePos := AStream.Position;
  for i := 0 to FThemeList.Count - 1 do
  begin
    if TteThemeClass(FThemeList[i]).CheckStream(AStream) then
    begin
      { Restore stream pos }
      AStream.Position := SavePos;
      { Load theme }
      Result := TteThemeClass(FThemeList[i]).Create;
      if not Result.LoadFromStream(AStream) then