Senin, 05 Mei 2008

mengambil font dari configurasi File

Nah bagi yang ingin mengambil font dari configurasi File maka disinilah tempatnya...
Silahkan anda simak artikel berikut ini yang di buat oleh Ali Reza Mortazavi

** mengambil font dari configurasi 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.

Semoga bermanfaat

Tidak ada komentar: