Tips (1541)

Tip Rating (20):

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.