373 lines
10 KiB
ObjectPascal
373 lines
10 KiB
ObjectPascal
unit TBX_DTM;
|
|
|
|
interface
|
|
|
|
uses classes, TBXDTMForm;
|
|
|
|
{$Warn symbol_Platform off}
|
|
|
|
type
|
|
TThemeFolderLocation = (flRelative, flAbsolute);
|
|
TThemeSettingsLocation = (slRegistry, slIniFile);
|
|
TTBXDynamicThemeManager = class(TComponent)
|
|
private
|
|
fPersistLast: boolean;
|
|
fAutoLoad: boolean;
|
|
fThemeFolder: string;
|
|
fFolderLocation: TThemeFolderLocation;
|
|
FFilterIndex: Integer;
|
|
FFilter: string;
|
|
fTitle: string;
|
|
fDefaultExt: string;
|
|
procedure LoadThemes(Sender:TObject; ThemeFiles:TStrings);
|
|
procedure UnloadTheme(Sender:TObject; ThemeIndex: Integer);
|
|
procedure RefreshThemes(Sender:TObject; ThemeList:TStrings);
|
|
procedure ActivateTheme(Sender:TObject; ThemeIndex:integer);
|
|
protected
|
|
procedure Loaded; override;
|
|
function ThemePath:string;
|
|
procedure AutoLoad;
|
|
procedure LoadLastTheme;
|
|
public
|
|
procedure Execute;
|
|
constructor Create(AOwner: TComponent); override;
|
|
published
|
|
property ThemeFolderLocation : TThemeFolderLocation read fFolderLocation write fFolderLocation default flRelative;
|
|
property ThemesFolder : string read fThemeFolder write fThemeFolder;
|
|
property Filter: string read FFilter write FFilter;
|
|
property FilterIndex: Integer read fFilterIndex write FFilterIndex default 1;
|
|
property DefaultExt : string read fDefaultExt write fDefaultExt;
|
|
property Title : string read fTitle write fTitle;
|
|
property AutoLoadThemes : boolean read fAutoLoad write fAutoLoad default false;
|
|
property PersistLastTheme : boolean read fPersistLast write fPersistLast default true;
|
|
end;
|
|
|
|
procedure UnloadThemes;
|
|
|
|
procedure Register;
|
|
|
|
implementation
|
|
|
|
uses Windows, dialogs, sysutils, IniFiles, TBX, TBXThemes, Math;
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('Toolbar2000', [TTBXDynamicThemeManager]);
|
|
end;
|
|
|
|
type
|
|
TThemeObj = class(TObject)
|
|
PackageHandle : THandle;
|
|
FileName : String;
|
|
ThemeName : ShortString;
|
|
end;
|
|
TThemeName = function : ShortString; stdcall;
|
|
TRegisterTheme = Procedure(RegisterTheme:boolean); stdcall;
|
|
|
|
var
|
|
gLoadedThemes : TList;
|
|
|
|
procedure UnloadThemes;
|
|
var
|
|
wTheme : TThemeObj;
|
|
P2 : TRegisterTheme;
|
|
begin
|
|
If CurrentTheme.Name <> 'Default' then
|
|
TBXSetTheme('Default');
|
|
while gLoadedThemes.Count > 0 do
|
|
begin
|
|
wTheme := gLoadedThemes[0];
|
|
P2 := GetProcAddress(wTheme.PackageHandle, 'TBXRegisterTheme');
|
|
P2(False);
|
|
gLoadedThemes.Delete(0);
|
|
UnloadPackage(wTheme.PackageHandle);
|
|
wTheme.free;
|
|
end;
|
|
end;
|
|
|
|
{ TTBXDynamicThemeManager }
|
|
|
|
procedure TTBXDynamicThemeManager.ActivateTheme(Sender:TObject; ThemeIndex:integer);
|
|
var
|
|
wFileName : string;
|
|
wThemeName : string;
|
|
wTheme : TThemeObj;
|
|
wIni : TIniFile;
|
|
begin
|
|
if fPersistLast then
|
|
begin
|
|
if ThemeIndex > -1 then
|
|
begin
|
|
wTheme := gLoadedThemes[ThemeIndex];
|
|
wFileName := wTheme.FileName;
|
|
wThemeName := wTheme.ThemeName;
|
|
end
|
|
else
|
|
begin
|
|
wThemeName := '';
|
|
wFileName := '';
|
|
end;
|
|
|
|
wIni := TIniFile.Create(ThemePath+'Theme.ini');
|
|
try
|
|
wIni.WriteString('ActiveTheme','FileName',wFileName);
|
|
wIni.WriteString('ActiveTheme','ThemeName',wThemeName);
|
|
finally
|
|
wIni.free;
|
|
end;
|
|
end;
|
|
|
|
if ThemeIndex > -1 then
|
|
TBXSetTheme(wThemeName)
|
|
else
|
|
TBXSetTheme('Default');
|
|
end;
|
|
|
|
procedure TTBXDynamicThemeManager.AutoLoad;
|
|
var
|
|
wFileList : TStringList;
|
|
dirinfo : TSearchRec;
|
|
ds : integer;
|
|
begin
|
|
if fAutoLoad then
|
|
begin
|
|
wFileList := TStringList.create;
|
|
try
|
|
ds := findfirst(ThemePath+'*.'+defaultext, $3f, dirinfo);
|
|
while ds = 0 do
|
|
begin
|
|
if dirinfo.Attr and fadirectory = 0 then
|
|
wFileList.add(ThemePath+dirinfo.Name);
|
|
ds := findnext(dirinfo);
|
|
end;
|
|
FindClose(dirinfo);
|
|
|
|
LoadThemes(self, wFileList);
|
|
finally
|
|
wFileList.free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
constructor TTBXDynamicThemeManager.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
fFilter := 'TBX Theme Package|*.tbxt|All Files|*.*';
|
|
FFilterIndex := 1;
|
|
fTitle := 'TBX Theme Manager';
|
|
fFolderLocation := flRelative;
|
|
fThemeFolder := 'Themes';
|
|
fDefaultExt := 'tbxt';
|
|
fPersistLast := true;
|
|
fAutoLoad := false;
|
|
end;
|
|
|
|
procedure TTBXDynamicThemeManager.Execute;
|
|
var
|
|
wFrm : TfrmTBXDTM;
|
|
begin
|
|
wFrm := TfrmTBXDTM.create(self);
|
|
try
|
|
wFrm.OnRefreshThemes := RefreshThemes;
|
|
wFrm.OnLoadNewTheme := LoadThemes;
|
|
wFrm.OnUnloadTheme := UnloadTheme;
|
|
wFrm.OnActivateTheme := ActivateTheme;
|
|
wFrm.Caption := fTitle;
|
|
wFrm.OpenDialog1.InitialDir := ThemePath;
|
|
wFrm.OpenDialog1.Title := fTitle;
|
|
wFrm.OpenDialog1.Filter := FFilter;
|
|
wFrm.OpenDialog1.FilterIndex := FFilterIndex;
|
|
wFrm.ShowModal;
|
|
finally
|
|
wFrm.free;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXDynamicThemeManager.Loaded;
|
|
begin
|
|
inherited;
|
|
if not (csdesigning in componentstate) then
|
|
begin
|
|
AutoLoad;
|
|
LoadLastTheme;
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXDynamicThemeManager.LoadLastTheme;
|
|
var
|
|
wIni : TIniFile;
|
|
wFile : TStringList;
|
|
wFileName : string;
|
|
wThemeName : string;
|
|
wFound : boolean;
|
|
loop : integer;
|
|
wTheme : TThemeObj;
|
|
begin
|
|
if fPersistLast and fileexists(ThemePath+'Theme.ini') then
|
|
begin
|
|
wIni := TIniFile.Create(ThemePath+'Theme.ini');
|
|
try
|
|
wFileName := trim(wIni.ReadString('ActiveTheme','FileName',''));
|
|
wThemeName := trim(wIni.ReadString('ActiveTheme','ThemeName',''));
|
|
finally
|
|
wIni.free;
|
|
end;
|
|
|
|
loop := 0;
|
|
wFound := false;
|
|
|
|
while not wFound and (loop < gLoadedThemes.count) do
|
|
begin
|
|
wTheme := gLoadedThemes[loop];
|
|
wFound := AnsiCompareText(wTheme.ThemeName, wThemeName) = 0;
|
|
if not wFound then
|
|
inc(loop);
|
|
end;
|
|
|
|
if not wFound and fileexists(wfilename) then
|
|
begin
|
|
wFile := TStringList.create;
|
|
try
|
|
wFile.add(wFileName);
|
|
LoadThemes(self, wFile);
|
|
finally
|
|
wFile.free;
|
|
end;
|
|
end;
|
|
|
|
if Trim(wThemeName) <> '' then
|
|
TBXSetTheme(wThemeName);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXDynamicThemeManager.LoadThemes(Sender: TObject; ThemeFiles: TStrings);
|
|
var
|
|
wTheme : TThemeObj;
|
|
loop : integer;
|
|
wFound : boolean;
|
|
wFoundName : string;
|
|
P1 : TThemeName;
|
|
P2 : TRegisterTheme;
|
|
begin
|
|
while ThemeFiles.Count > 0 do
|
|
begin
|
|
wFound := false;
|
|
loop := 0;
|
|
while not wFound and (loop < gLoadedThemes.Count) do
|
|
begin
|
|
wTheme := gLoadedThemes[loop];
|
|
wFound := AnsiCompareText(extractfilename(wTheme.FileName), extractfilename(ThemeFiles[0])) = 0;
|
|
if not wFound then
|
|
inc(loop)
|
|
else
|
|
wFoundName := wTheme.ThemeName;
|
|
end;
|
|
|
|
if wFound then
|
|
begin
|
|
messagedlg(wFoundName+' is already loaded', mtError, [mbok], 0);
|
|
end
|
|
else
|
|
begin
|
|
wTheme := TThemeObj.create;
|
|
try
|
|
wTheme.FileName := ThemeFiles[0];
|
|
wTheme.PackageHandle := LoadPackage(ThemeFiles[0]);
|
|
|
|
if wTheme.PackageHandle > 0 then
|
|
begin
|
|
P2 := GetProcAddress(wTheme.PackageHandle, 'TBXRegisterTheme');
|
|
P1 := GetProcAddress(wTheme.PackageHandle, 'TBXThemeName');
|
|
if Assigned(P1) and Assigned(P2) then
|
|
begin
|
|
Try
|
|
P2(true);
|
|
except
|
|
messagedlg('An unknown error has occured while trying to register the theme file:'#13#10#13#10+ThemeFiles[0], mterror, [mbok], 0);
|
|
abort;
|
|
end;
|
|
|
|
if IsTBXThemeAvailable(P1) then
|
|
begin
|
|
wTheme.ThemeName := P1;
|
|
gLoadedThemes.Add(wTheme);
|
|
end
|
|
else
|
|
begin
|
|
messagedlg('An unknown error has occured while trying to load the theme file:'#13#10#13#10+ThemeFiles[0], mterror, [mbok], 0);
|
|
Abort;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
messagedlg('Unable to load the specified TBX Theme file.'#13#10#13#10+ThemeFiles[0], mterror, [mbok], 0);
|
|
Abort;
|
|
end;
|
|
end
|
|
else
|
|
begin
|
|
messagedlg('Unable to load the specified TBX Theme file.'#13#10#13#10+ThemeFiles[0], mterror, [mbok], 0);
|
|
Abort;
|
|
end;
|
|
except
|
|
if wTheme.PackageHandle > 0 then
|
|
UnloadPackage(wTheme.PackageHandle);
|
|
freeandnil(wTheme);
|
|
end;
|
|
end;
|
|
ThemeFiles.delete(0);
|
|
end;
|
|
end;
|
|
|
|
procedure TTBXDynamicThemeManager.RefreshThemes(Sender: TObject;
|
|
ThemeList: TStrings);
|
|
var
|
|
loop : integer;
|
|
wTheme : TThemeObj;
|
|
begin
|
|
ThemeList.Clear;
|
|
for loop := 0 to gLoadedThemes.Count-1 do
|
|
begin
|
|
wTheme := gLoadedThemes[loop];
|
|
ThemeList.Add(wTheme.ThemeName);
|
|
end;
|
|
end;
|
|
|
|
function TTBXDynamicThemeManager.ThemePath: string;
|
|
begin
|
|
if fFolderLocation = flRelative then
|
|
result := extractfilepath(ParamStr(0))+fThemeFolder
|
|
else
|
|
result := fThemeFolder;
|
|
|
|
result := IncludeTrailingBackslash(result);
|
|
if not DirectoryExists(result) then
|
|
ForceDirectories(result);
|
|
end;
|
|
|
|
procedure TTBXDynamicThemeManager.UnloadTheme(Sender: TObject; ThemeIndex: Integer);
|
|
var
|
|
wTheme : TThemeObj;
|
|
P2 : TRegisterTheme;
|
|
begin
|
|
try
|
|
wTheme := gLoadedThemes[ThemeIndex];
|
|
P2 := GetProcAddress(wTheme.PackageHandle, 'TBXRegisterTheme');
|
|
P2(False);
|
|
UnloadPackage(wTheme.PackageHandle);
|
|
gLoadedThemes.Delete(ThemeIndex);
|
|
freeandnil(wTheme);
|
|
except
|
|
messagedlg('Unable to remove the theme at this time.', mtinformation, [mbok], 0);
|
|
end
|
|
end;
|
|
|
|
initialization
|
|
gLoadedThemes := TList.create;
|
|
|
|
finalization
|
|
UnloadThemes;
|
|
gLoadedThemes.free;
|
|
|
|
end.
|