tetheme.pas

这个东西的功能很强大

procedure RepaintThemedControls;
begin
  ThemeManager.Broadcast(SNM_THEMEMESSAGE, SMP_REPAINT, 0);
end;

procedure ChangeThemeHue(ADelta: integer);
begin
  if CurrentTheme <> nil then
  begin
    CurrentTheme.ChangeThemeHue(ADelta);
    ThemeManager.Broadcast(SNM_THEMEMESSAGE, SMP_REPAINT, 1);
  end;
end;

procedure ChangeThemeBrightness(ADelta: integer);
begin
  if CurrentTheme <> nil then
  begin
    CurrentTheme.ChangeThemeBrightness(ADelta);
    ThemeManager.Broadcast(SNM_THEMEMESSAGE, SMP_REPAINT, 1);
  end;
end;

function GetThemeClass(ClassName: string): TteThemeClass;
begin
  Result := ThemeManager.GetThemeClass(ClassName);
end;




type

  TteHackTheme = class(TteTheme);

procedure SetFont(AFont: TFont; AFontName: string;
  AFontSize: integer; AFontStyle: TFontStyles; AFontColor: TColor);
begin
  AFont.Name := AFontName;
  AFont.Size := AFontSize;
  AFont.Style := AFontStyle;
  AFont.Color := AFontColor;
end;

function FontToString(Font: TFont): string;
begin
  Result := Font.Name + ',' + IntToStr(Font.Size) + ',' + IntToStr(Font.Charset) + ',' + IntToStr(GetRValue(Font.Color)) + ',' + IntToStr(GetGValue(Font.Color)) + ',' + IntToStr(GetBValue(Font.Color));

  if fsBold in Font.Style then Result := Result + ',bold';
  if fsItalic in Font.Style then Result := Result + ',italic';
  if fsUnderline in Font.Style then Result := Result + ',underline';
  if fsStrikeOut in Font.Style then Result := Result + ',strikeout';
end;

function StringToFontName(S: string): string;
begin
  Result := GetToken(S, ';,');
end;

function StringToFontSize(S: string): integer;
begin
  GetToken(S, ';,'); // Skip font name
  Result := StrToInt(GetToken(S));
end;

function StringToFontCharset(S: string): TFontCharset;
begin
  GetToken(S, ';,'); // Skip font name
  GetToken(S, ';,'); // Skip font size
  Result := StrToInt(GetToken(S));
end;

function StringToFontColor(S: string): TColor;
var
  R, G, B: integer;
begin
  GetToken(S, ';,'); // Skip font name
  GetToken(S, ';,'); // Skip font size
  GetToken(S, ';,'); // Skip font charset
  R := StrToInt(GetToken(S));
  G := StrToInt(GetToken(S));
  B := StrToInt(GetToken(S));
  Result := RGB(R, G, B);
end;

function StringToFontStyle(S: string): TFontStyles;
var
  T: string;
begin
  GetToken(S, ';,'); // Skip font name
  GetToken(S, ';,'); // Skip font size
  GetToken(S, ';,'); // Skip font charset
  GetToken(S, ';,');GetToken(S, ';,');GetToken(S, ';,'); // Skip font color

  Result := [];

  T := GetToken(S, ';,');
  if T <> '' then Result := Result + [fsBold];

  T := GetToken(S, ';,');
  if T <> '' then Result := Result + [fsItalic];

  T := GetToken(S, ';,');
  if T <> '' then Result := Result + [fsUnderline];

  T := GetToken(S, ';,');
  if T <> '' then Result := Result + [fsStrikeOut];
end;

{ TteColorList ================================================================}

constructor TteThemeColors.Create;
begin
  inherited Create;
  FTheme := ATheme;
end;

procedure TteThemeColors.Assign(Source: TPersistent);
var
  i: TteThemeColor;
begin
  if Source is TteThemeColors then
  begin
    for i := Low(FColorList) to High(FColorList) do
    begin
      FColorList[i] := (Source as TteThemeColors).FColorList[i];
    end;
  end
  else
    inherited;
end;

procedure TteThemeColors.ChangeColorsHue(ADelta: integer);
var
  i: TteThemeColor;
begin
  for i := Low(FColorList) to High(FColorList) do
    FColorList[i] := teColorToColor(ChangeHue(teColor(FColorList[i]), ADelta));
end;

procedure TteThemeColors.ChangeColorsBrightness(ADelta: integer);
var
  i: TteThemeColor;
begin
  for i := Low(FColorList) to High(FColorList) do
    FColorList[i] := teColorToColor(ChangeBrightness(teColor(FColorList[i]), ADelta));
end;

procedure TteThemeColors.LoadFromStream(Stream: TStream);
var
  Count, i: TteThemeColor;
begin
  Stream.Read(Count, SizeOf(Count));

  for i := Low(FColorList) to TteThemeColor(Count) do
  begin
    ReadString(Stream); // name
    ReadString(Stream); // :
    FColorList[i] := StringToColor(ReadString(Stream));
  end;
end;

procedure TteThemeColors.SaveToStream(Stream: TStream);
var
  i, Count: TteThemeColor;
begin
  Count := High(FColorList);
  Stream.Write(Count, SizeOf(Count));

  for i := Low(FColorList) to High(FColorList) do
  begin
    WriteString(Stream, ThemeColorNames[i]);
    WriteString(Stream, ':');
    WriteString(Stream, ColorToString(FColorList[i]));
  end;
end;

function TteThemeColors.GetColor(index: TteThemeColor): TColor;
begin
  Result := FColorList[index];
end;

procedure TteThemeColors.SetColor(index: TteThemeColor; const Value: TColor);
begin
  FColorList[index] := Value;
end;

{ TteThemeFonts ===============================================================}

constructor TteThemeFonts.Create;
var
  i: TteThemeFont;
begin
  inherited Create;

  FTheme := ATheme;
  FThemeFont := TFont.Create;
  for i := Low(FFontList) to High(FFontList) do
  begin
    FFontList[i] := TFont.Create;
    FFontList[i].Name := 'Tahoma';
  end;
end;

destructor TteThemeFonts.Destroy;
var
  i: TteThemeFont;
begin
  for i := Low(FFontList) to High(FFontList) do
    FFontList[i].Free;
  FThemeFont.Free;

  inherited;
end;

procedure TteThemeFonts.Assign(Source: TPersistent);
var
  i: TteThemeFont;
begin
  if Source is TteThemeFonts then
  begin
    for i := Low(FFontList) to High(FFontList) do
      FFontList[i].Assign((Source as TteThemeFonts).FFontList[i]);
  end
  else
    inherited;
end;

procedure TteThemeFonts.ChangeFontsHue(ADelta: integer);
var
  i: TteThemeFont;
begin
  for i := Low(FFontList) to High(FFontList) do
    FFontList[i].Color := teColorToColor(ChangeHue(teColor(FFontList[i].Color), ADelta));
end;

procedure TteThemeFonts.ChangeFontsBrightness(ADelta: integer);
var
  i: TteThemeFont;
begin
  for i := Low(FFontList) to High(FFontList) do
    FFontList[i].Color := teColorToColor(ChangeBrightness(teColor(FFontList[i].Color), ADelta));
end;

procedure TteThemeFonts.LoadFromStream(Stream: TStream);
var
  Count, i: TteThemeFont;
  FontString: string;
begin
  Stream.Read(Count, SizeOf(Count));

  for i := Low(FFontList) to TteThemeFont(Count) do
  begin
    ReadString(Stream); // name
    ReadString(Stream); // :
    FontString := ReadString(Stream);

    { Decode }
    FFontList[i].Name := StringToFontName(FontString);
    FFontList[i].Size := StringToFontSize(FontString);
    FFontList[i].Color := StringToFontColor(FontString);
    FFontList[i].Style := StringToFontStyle(FontString);
  end;
end;

procedure TteThemeFonts.SaveToStream(Stream: TStream);
var
  i, Count: TteThemeFont;
begin
  Count := High(FFontList);
  Stream.Write(Count, SizeOf(Count));

  for i := Low(FFontList) to High(FFontList) do
  begin
    WriteString(Stream, ThemeFontNames[i]);
    WriteString(Stream, ':');
    WriteString(Stream, FontToString(FFontList[i]));
  end;
end;

function TteThemeFonts.GetFont(index: TteThemeFont): TFont;
begin
  Result := FFontList[index];
end;

procedure TteThemeFonts.SetFont(index: TteThemeFont; const Value: TFont);
begin
  FFontList[index].Assign(Value);
end;

function TteThemeFonts.GetFontForObject(Font: TteThemeFont;
  const AObject: TteThemeObject): TFont;
begin
  if (FTheme <> nil) and (AObject <> ktoDefault) then
  begin
    TteHackTheme(FTheme).SetFontForObject(FThemeFont, Font, AObject);
    Result := FThemeFont;
  end
  else
    Result := Fonts[Font];
end;



{ }

function IsObjectDefined(const ASubclass: TteWindowSubclass;
  const AObject: TteThemeObject = ktoDefault): boolean;
begin
  if CurrentTheme <> nil then
    Result := CurrentTheme.IsWindowDefined(ASubclass, AObject)
  else
    Result := false;
end;


function IsObjectDefined(const ASubclass: TteButtonSubclass;
  const AObject: TteThemeObject = ktoDefault): boolean; overload;
begin
  if CurrentTheme <> nil then
    Result := CurrentTheme.IsButtonDefined(ASubclass, AObject)
  else
    Result := false;
end;

function IsObjectDefined(const ASubclass: TteScrollSubclass;
  const AObject: TteThemeObject = ktoDefault): boolean; overload;
begin
  if CurrentTheme <> nil then
    Result := CurrentTheme.IsScrollDefined(ASubclass, AObject)
  else
    Result := false;
end;


function IsObjectDefined(const ASubclass: TteMenuSubclass;
  const AObject: TteThemeObject = ktoDefault): boolean; overload;
begin
  if CurrentTheme <> nil then
    Result := CurrentTheme.IsMenuDefined(ASubclass, AObject)
  else
    Result := false;
end;

function IsObjectDefined(const ASubclass: TteBarSubclass;
  const AObject: TteThemeObject = ktoDefault): boolean; overload;
begin
    Result := false;
end;


{ TteTheme class ===============================================================}


constructor TteTheme.Create;
begin
  inherited Create;
  FThemeName := 'Default theme';
  FColors := TteThemeColors.Create(Self);
  FFonts := TteThemeFonts.Create(Self);

  ResetTheme;
end;

destructor TteTheme.Destroy;
begin
  FreeAndNil(FFonts);
  FreeAndNil(FColors);
  inherited Destroy;
end;

{ Options }

class function TteTheme.GetThemeOptions: TteThemeOptions;
begin
  Result.Building := false;
  Result.CanStore := false;
  Result.DialogFilter := '';
  Result.DefaultExt := '';
end;

{ Class methods }

class function TteTheme.GetThemeName: string;
begin
  Result := 'Default';
end;

procedure TteTheme.Assign(Source: TPersistent);
begin
  if Source is TteTheme then
  begin
    FThemeName := TteTheme(Source).FThemeName;
    FThemeName := TteTheme(Source).FThemeName;
  end
  else
    inherited;
end;

function TteTheme.CreateCopy: TteTheme;
var
  ClassType: TteThemeClass;
begin
  ClassType := GetThemeClass(ClassName);
  if ClassType <> nil then
  begin
    Result := ClassType.Create;
    Result.Assign(Self);
  end
  else
    Result := nil;
end;

{ I/O }

class function TteTheme.CheckStream(Stream: TStream): boolean;
begin
  Result := false;
end;

function TteTheme.LoadFromStream(Stream: TStream): boolean;
begin
  Result := false;
end;

function TteTheme.SaveToStream(Stream: TStream): boolean;
begin
  Result := false;
end;

function TteTheme.LoadFromFile(FileName: string): boolean;
begin
  Result := false;
end;

function TteTheme.SaveToFile(FileName: string): boolean;
begin
  Result := false;
end;

{ Reset theme }

procedure TteTheme.ResetThemeColors;
begin
  FColors[ktcCaptionNormal] := clBlue;
  FColors[ktcCaptionInactive] := clSilver;
  FColors[ktcWindowBorder] := clGray;
  FColors[ktcWindow] := clSilver;
  FColors[ktcButtonNormal] := clSilver;
  FColors[ktcButtonHot] := clSilver;
  FColors[ktcButtonPressed] := clSilver;
  FColors[ktcButtonFocused] := clSilver;
  FColors[ktcButtonDisabled] := clSilver;

  FColors.ChangeColorsHue(FHue);
  FColors.ChangeColorsBrightness(FBrightness);
end;

procedure TteTheme.SetFontForObject(AFont: TFont;
  const Font: TteThemeFont; const AObject: TteThemeObject);
begin
  AFont.Assign(Fonts[Font]);
end;

procedure TteTheme.ResetThemeFonts;
begin
  SetFont(FFonts[ktfCaptionTextNormal], 'Tahoma', 10, [fsBold], clWhite);
  SetFont(FFonts[ktfCaptionTextInactive], 'Tahoma', 10, [fsBold], clSilver);
  SetFont(FFonts[ktfSmCaptionTextNormal], 'Tahoma', 8, [fsBold], clWhite);
  SetFont(FFonts[ktfSmCaptionTextInactive], 'Tahoma', 8, [fsBold], clSilver);
  SetFont(FFonts[ktfButtonTextNormal], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfButtonTextPressed], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfButtonTextHot], 'Tahoma', 8, [], clRed);
  SetFont(FFonts[ktfButtonTextFocused], 'Tahoma', 8, [fsBold], clBlack);
  SetFont(FFonts[ktfButtonTextDisabled], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfCheckBoxTextNormal], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfCheckBoxTextPressed], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfCheckBoxTextHot], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfCheckBoxTextFocused], 'Tahoma', 8, [fsBold], clBlack);
  SetFont(FFonts[ktfCheckBoxTextDisabled], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfRadioButtonTextNormal], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfRadioButtonTextPressed], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfRadioButtonTextHot], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfRadioButtonTextFocused], 'Tahoma', 8, [fsItalic], clBlack);
  SetFont(FFonts[ktfRadioButtonTextDisabled], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfGroupBoxTextNormal], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfGroupBoxTextDisabled], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfWindowTextNormal], 'Tahoma', 8, [], clBlack);
  SetFont(FFonts[ktfWindowTextDisabled],  'Tahoma', 8, []