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.