Home page > Delphi, tips bulk > Miscellaneous > XE2VCLStyles: managing XE2/VCL styles

XE2VCLStyles: managing XE2/VCL styles

Saturday 17 September 2011, by CapJack

This unit is reserved for Delphi XE2, and only for VCL Forms (FMX version may be released one day, but patience ...).

It shows you how to automatically load styles from .vsf files contained in a subdirectory, in addition to any embedded styles defined in "Project/Options".

Enabling you to your end user to further customize its application. There are different .vsf files freely downloadable on the Internet.

I’m not asking anything in return for this work, except a small link to my site if you find it useful and use it in your software.

CapJack.

  1. (*********************************************************)
  2. (***)                                                 (***)
  3. (***)              UNIT XE2VCLStyles;                 (***)
  4. (***)                                                 (***)
  5. (*********************************************************)
  6.  
  7. (*********************************************************)
  8. (* Feel free to use it, but at your own risk!            *)
  9. (* À utiliser librement, mais à vos risques et périls !  *)
  10. (* CapJack.                                              *)
  11. (*********************************************************)
  12.  
  13.  
  14. (*********************************************************)
  15. (***)                                                 (***)
  16. (***)                  INTERFACE                      (***)
  17. (***)                                                 (***)
  18. (*********************************************************)
  19.  
  20. uses Classes;
  21.  
  22. const SubFolder    = 'Styles\';
  23.       DefaultExt   = '.vsf';
  24.  
  25. (*********************************************************)
  26. (* XE2VCLStylesEnabled                                   *)
  27. (* ----------------------------------------------------- *)
  28. (* Returns only "true" or "false" depending on whether   *)
  29. (* the version of Delphi used manage or not styles.      *)
  30. (* Unit can so be used with any version of Delphi.       *)
  31. (* ----------------------------------------------------- *)
  32. (* Renvoie simplement "true" ou "false" suivant que la   *)
  33. (* version de Delphi utilisée gère ou pas les styles.    *)
  34. (* Unité utilisable ainsi avec toute version de Delphi.  *)
  35. (*********************************************************)
  36.  
  37. function  XE2VCLStylesEnabled : Boolean;
  38.  
  39. (*********************************************************)
  40. (* XE2VCLStylesGetNames                                  *)
  41. (* ----------------------------------------------------- *)
  42. (* Returns the name of all the styles registered,        *)
  43. (* includes embedded styles and those automatically      *)
  44. (* detected in the "Styles" folder.                      *)
  45. (* ----------------------------------------------------- *)
  46. (* Renvoie le nom de tous les styles enregistrés, ce qui *)
  47. (* inclut les styles embarqués et ceux qui ont été       *)
  48. (* automatiquement détectés dans le répertoire "Styles". *)
  49. (*********************************************************)
  50.  
  51. procedure XE2VCLStylesGetNames(AStrings:TStrings);
  52.  
  53. (*********************************************************)
  54. (* XE2VCLStylesSetStyle                                  *)
  55. (* ----------------------------------------------------- *)
  56. (* Applies the style indicated. Returns True if ok.      *)
  57. (* ----------------------------------------------------- *)
  58. (* Applique le style indiqué. Renvoie True si ok.        *)
  59. (*********************************************************)
  60.  
  61. function  XE2VCLStylesSetStyle(AName: string): Boolean;
  62.  
  63.  
  64. (*********************************************************)
  65. (***)                                                 (***)
  66. (***)                 IMPLEMENTATION                  (***)
  67. (***)                                                 (***)
  68. (*********************************************************)
  69.  
  70. {---------------------------------------------------------}
  71.  
  72. // If we are under Delphi XE2 or more
  73.  
  74. // Si nous sommes sous Delphi XE2 ou supérieur
  75.  
  76. {$IFDEF DCC}
  77.  
  78. {---------------------------------------------------------}
  79.  
  80. uses System.SysUtils,
  81.      VCL.Forms, VCL.Dialogs, VCL.Styles, VCL.Themes;
  82.  
  83. var InternalStyleManager : TStyleManager;
  84.     StylesSubFolder      : string;
  85.     DefaultStyle         : string; // Normally 'Windows'
  86.  
  87. {---------------------------------------------------------}
  88.  
  89. // Returns true, environment manages styles.
  90.  
  91. // Renvoie true, l'environnement gère les styles.
  92.  
  93. function  XE2VCLStylesEnabled : Boolean;
  94. begin
  95.  Result := true;
  96. end;
  97.  
  98. {---------------------------------------------------------}
  99.  
  100. procedure GetFilesInDir
  101.         (
  102.         const ADir              : string;
  103.         const AList             : TStrings;
  104.         const AMask             : string = ''
  105.         );
  106.   var Mask : string;
  107.  
  108.   procedure GetFilesOnly(subdir:string);
  109.    var T : TSearchRec;
  110.        R : Integer;
  111.        D : string;
  112.    begin
  113.     T.Name:='';
  114.     FillChar(T,SizeOf(T),0);
  115.     D:=IncludeTrailingPathDelimiter(subdir);
  116.     R := FindFirst(D+Mask,faAnyFile and not (faDirectory),T);
  117.     while R = 0 do
  118.      begin
  119.       if Assigned(AList) then AList.Add(D + T.Name);
  120.       R := FindNext(T);
  121.      end;
  122.     FindClose(T);
  123.    end;
  124.  
  125.  begin
  126.   if Assigned(AList) then
  127.     begin
  128.      AList.Clear;
  129.      if AMask = '' then Mask := '*.*' else Mask := AMask;
  130.      GetFilesOnly(ADir);
  131.     end;
  132.  end;
  133.  
  134. {---------------------------------------------------------}
  135.  
  136. procedure InitInternalVarsIfNeeded;
  137.  var I : Integer; lFileList: TStringList;
  138.  begin
  139.  
  140.   // Initialize styles subfolder path name.
  141.  
  142.   // Initialise le nom du sous répertoire des styles.
  143.  
  144.   if StylesSubFolder = ''
  145.      then begin
  146.            StylesSubFolder:=
  147.                IncludeTrailingPathDelimiter
  148.                    (ExtractFileDir(ParamStr(0)))
  149.                + SubFolder;
  150.           end;
  151.  
  152.   // Instanciate a style manager.
  153.  
  154.   // Instancie un gestionnaire de styles.
  155.  
  156.   if not assigned(InternalStyleManager)
  157.      then begin
  158.            InternalStyleManager := TStyleManager.Create;
  159.  
  160.            with InternalStyleManager do
  161.             begin
  162.              Initialize;
  163.              DefaultStyle := StyleNames[0];
  164.  
  165.              // Get sub-folder style names and load them;
  166.              // embedded ones (in Project/Options) are
  167.              // already registered by Initialize.
  168.  
  169.              // Récupère les styles du sous-répertoire
  170.              // et les charge. Les styles embarqués
  171.              // (dans Projet/Options) sont déjà chargés
  172.              // par la procédure Initialize.
  173.  
  174.              if DirectoryExists(StylesSubFolder) then
  175.               begin
  176.                lFileList := TStringList.Create;
  177.                GetFilesInDir(
  178.                               StylesSubFolder,
  179.                               lFileList,
  180.                               '*'+DefaultExt
  181.                             );
  182.  
  183.                for I := 0 to lFileList.Count - 1 do
  184.                 if IsValidStyle(lFileList[I])
  185.                    then begin
  186.                          try
  187.                           LoadFromFile(lFileList[I]);
  188.                          except
  189.  
  190.                           // We have an exception
  191.                           // in case the declared name
  192.                           // is already registered.
  193.                           // Embedded style has priority.
  194.  
  195.                           // Une exception de déclenche
  196.                           // si le nom d'un style entre
  197.                           // en conflit avec celui d'un
  198.                           // style embarqué.
  199.                           // Le style embarqué a priorité.
  200.  
  201.                           on E:Exception do;
  202.                          end;
  203.                         end;
  204.  
  205.                lFileList.Free;
  206.               end; // if DirectoryExists(...)
  207.             end; // with InternalStyleManager...
  208.           end; // if not assigned(...)
  209.  end;
  210.  
  211. {---------------------------------------------------------}
  212.  
  213. procedure FreeInternalVarsIfNeeded;
  214.  begin
  215.   if assigned(InternalStyleManager)
  216.      then FreeAndNil(InternalStyleManager);
  217.  end;
  218.  
  219. {---------------------------------------------------------}
  220.  
  221. procedure  XE2VCLStylesGetNames(AStrings:TStrings);
  222.  var I: Integer; lStrings: TStringList;
  223.  begin
  224.   if not assigned(AStrings) then exit;
  225.   InitInternalVarsIfNeeded;
  226.   lStrings := TStringList.Create;
  227.  
  228.   with InternalStyleManager do
  229.        for I := 0 to Length(StyleNames)-1
  230.            do lStrings.Add(StyleNames[I]);
  231.  
  232.   lStrings.Sort;
  233.   AStrings.Assign(lStrings);
  234.   FreeAndNil(lStrings);
  235.  end;
  236.  
  237. {---------------------------------------------------------}
  238.  
  239. function  XE2VCLStylesSetStyle(AName: string): Boolean;
  240.  var lName : string;
  241.  begin
  242.    InitInternalVarsIfNeeded;
  243.    if AName = ''
  244.       then lName := DefaultStyle
  245.       else lName := AName;
  246.    Result := InternalStyleManager.TrySetStyle(lName,true);
  247.  end;
  248.  
  249. {---------------------------------------------------------}
  250.  
  251. INITIALIZATION
  252.  InternalStyleManager := nil;
  253.  StylesSubFolder := '';
  254.  DefaultStyle := '';
  255.  
  256. FINALIZATION
  257.  FreeInternalVarsIfNeeded;
  258.  
  259. {---------------------------------------------------------}
  260.  
  261. // If we are not under Delphi XE2 or more.
  262.  
  263. // Si nous ne sommes pas sous Delphi XE2 ou supérieur.
  264.  
  265. {$ELSE}
  266.  
  267. {---------------------------------------------------------}
  268.  
  269. // Returns false, environment doesn't manage styles.
  270.  
  271. // Renvoie false, l'environnement ne gère pas les styles.
  272.  
  273. function  XE2VCLStylesEnabled : Boolean;
  274.  begin
  275.    Result := false;
  276.  end;
  277.  
  278. {---------------------------------------------------------}
  279.  
  280. // Returns an empty list, there is no style.
  281.  
  282. // Ranvoie une liste vide, il n'y a pas de styles.
  283.  
  284. procedure  XE2VCLStylesGetNames(AStrings:TStrings);
  285.  begin
  286.    if not assigned(AStrings) then exit;
  287.    AStrings.Clear;
  288.  end;
  289.  
  290. {---------------------------------------------------------}
  291.  
  292. // Returns false, unable to set a style.
  293.  
  294. // Renvoie false, impossible d'appliquer un style.
  295.  
  296. function  XE2VCLStylesSetStyle(AName: string): Boolean;
  297.  begin
  298.    Result := False;
  299.  end;
  300.  
  301. {---------------------------------------------------------}
  302.  
  303. {$ENDIF DCC }
  304.  
  305. {---------------------------------------------------------}
  306.  
  307. END.