Title: save and Load Font from a configuration file?
unit DelphiCenterU1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IniFiles;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
ListBox1: TListBox;
FontDialog1: TFontDialog;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
var
MyFile: string = 'C:\Font.Ini';
(*----------------------------------------------------*)
function FontStyletoStr(St: TFontStyles): string;
var
S: string;
begin
S := '';
if St = [fsbold] then S := 'Bold'
else if St = [fsItalic] then S := 'Italic'
else if St = [fsStrikeOut] then S := 'StrikeOut'
else if St = [fsUnderline] then S := 'UnderLine'
else if St = [fsbold, fsItalic] then S := 'BoldItalic'
else if St = [fsBold, fsStrikeOut] then S := 'BoldStrike'
else if St = [fsBold, fsUnderline] then S := 'BoldUnderLine'
else if St = [fsBold..fsStrikeOut] then S := 'BoldItalicStrike'
else if St = [fsBold..fsUnderLine] then S := 'BoldItalicUnderLine'
else if St = [fsbold..fsItalic, fsStrikeOut] then S := 'BoldItalicStrike'
else if St = [fsBold, fsUnderline..fsStrikeOut] then S := 'BoldStrikeUnderLine'
else if St = [fsItalic, fsStrikeOut] then S := 'ItalicStrike'
else if St = [fsItalic..fsUnderline] then S := 'ItalicUnderLine'
else if St = [fsUnderLine..fsStrikeOut] then S := 'UnderLineStrike'
else if St = [fsItalic..fsStrikeOut] then S := 'ItalicUnderLineStrike';
FontStyletoStr := S;
end;
(*----------------------------------------------------*)
function StrtoFontStyle(St: string): TFontStyles;
var
S: TfontStyles;
begin
S := [];
St := UpperCase(St);
if St = 'BOLD' then S := [fsBold]
else if St = 'ITALIC' then S := [fsItalic]
else if St = 'STRIKEOUT' then S := [fsStrikeOut]
else if St = 'UNDERLINE' then S := [fsUnderLine]
else if St = 'BOLDITALIC' then S := [fsbold, fsItalic]
else if St = 'BOLDSTRIKE' then S := [fsBold, fsStrikeOut]
else if St = 'BOLDUNDERLINE' then S := [fsBold, fsUnderLine]
else if St = 'BOLDITALICSTRIKE' then S := [fsBold..fsStrikeOut]
else if St = 'BOLDITALICUNDERLINE' then S := [fsBold..fsUnderLine]
else if St = 'BOLDITALICSTRIKE' then S := [fsbold..fsItalic, fsStrikeOut]
else if St = 'BOLDSTRIKEUNDERLINE' then S := [fsBold, fsUnderline..fsStrikeOut]
else if St = 'ITALICSTRIKE' then S := [fsItalic, fsStrikeOut]
else if St = 'ITALICUNDERLINE' then S := [fsItalic..fsUnderline]
else if St = 'UNDERLINESTRIKE' then S := [fsUnderLine..fsStrikeOut]
else if St = 'ITALICUNDERLINESTRIKE' then S := [fsItalic..fsStrikeOut];
StrtoFontStyle := S;
end;
(*----------------------------------------------------*)
//Example for Write Font
procedure SaveFont(S: string);
var
Ini: TIniFile;
begin
Ini := TIniFile.Create(S);
with Form1.ListBox1 do
begin
with Font do
begin
Ini.WriteString('Fonts', 'List Name', Name);
Ini.WriteInteger('Fonts', 'List Size', Size);
Ini.WriteInteger('Fonts', 'List Color', Color);
S := FontStyletoStr(Style);
if S '' then Ini.WriteString('Fonts', 'List Style', S);
end;
Ini.WriteInteger('Colors', 'List Color', Color);
end;
Ini.Free;
end;
(*----------------------------------------------------*)
//Example for Read Font
procedure LoadFont(S: string);
var
Ini: TIniFile;
begin
Ini := TIniFile.Create(S);
with Form1.ListBox1 do
begin
with Font do
begin
Name := Ini.ReadString('Fonts', 'List Name', Name);
Size := Ini.ReadInteger('Fonts', 'List Size', Size);
Color := Ini.ReadInteger('Fonts', 'List Color', Color);
S := Ini.ReadString('Fonts', 'List Style', '');
if S '' then Style := StrtoFontStyle(S);
end;
Color := Ini.ReadInteger('Colors', 'List Color', Color);
end;
Ini.Free;
end;
(*----------------------------------------------------*)
procedure TForm1.Button1Click(Sender: TObject);
begin
SaveFont(MyFile);
end;
(*----------------------------------------------------*)
procedure TForm1.Button2Click(Sender: TObject);
begin
LoadFont(MyFile);
end;
(*----------------------------------------------------*)
procedure TForm1.ListBox1Click(Sender: TObject);
begin
with FontDialog1 do if Execute then ListBox1.Font := Font;
end;
(*----------------------------------------------------*)
procedure TForm1.FormCreate(Sender: TObject);
var
i: Byte;
begin
for i := 1 to 10 do
ListBox1.Items.Add('Item ' + IntToStr(i));
end;
(*----------------------------------------------------*)
end.