home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 May / Chip_2002-05_cd1.bin / sharewar / fontlist / UNIT1.PAS < prev   
Pascal/Delphi Source File  |  1998-08-24  |  3KB  |  82 lines
  1. unit Unit1;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, ComCtrls, ExtCtrls, Spin, Grids, SortGrid, Printers;
  8.  
  9. type
  10.   TFontForm = class(TForm)
  11.     Panel1: TPanel;
  12.     RichEdit1: TRichEdit;
  13.     Button1: TButton;
  14.     ProgressBar1: TProgressBar;
  15.     Label2: TLabel;
  16.     SaveDialog1: TSaveDialog;
  17.     RadioButton1: TRadioButton;
  18.     RadioButton2: TRadioButton;
  19.     Label3: TLabel;
  20.     procedure Button1Click(Sender: TObject);
  21.     procedure FormShow(Sender: TObject);
  22.   private
  23.     { Private declarations }
  24.     StopAction:boolean;
  25.     OutFile:string;
  26.   public
  27.     { Public declarations }
  28.   end;
  29.  
  30. var
  31.   FontForm: TFontForm;
  32.  
  33. implementation
  34.  
  35. {$R *.DFM}
  36.  
  37. procedure TFontForm.Button1Click(Sender: TObject);
  38. var a,b,c:integer;
  39.     s,r,t:string;
  40.     L:TStringList;
  41.     tf:TextFile;
  42. begin
  43.  if Button1.Caption='Stop' then begin
  44.   StopAction:=true;
  45.   Exit;
  46.  end else StopAction:=false;
  47.  Button1.Caption:='Stop';
  48.  ProgressBar1.Max:=Screen.Fonts.Count-1;
  49.  L:=TStringList.Create;
  50.  r:='{\rtf1\ansi\deff0\deftab720{\fonttbl{\f0\fnil MS Sans Serif;}{\f1\fnil\fcharset2{\*\fname Symbol;}MT Symbol;}{\f2\fswiss\fprq2 System;}{\f3\fnil\fcharset1 MS Sans Serif;}{\f4\fnil\fcharset238{\*\fname MS Sans Serif;}MS Shell Dlg;}';
  51.  t:='{\colortbl\red0\green0\blue0;}'+#13+#10+'\deflang1033\pard\tx3000\tx4400\tx5400\tx6800\'+#13+#10;
  52.  if RadioButton1.Checked then L.Assign(Printer.Fonts)
  53.   else L.Assign(Screen.Fonts);
  54.  L.Sort;
  55.  for a:=0 to  L.Count-1 do begin
  56.   r:=r+'{\f'+IntToStr(a+5)+'\fnil\fcharset1 '+L[a]+';}';
  57.   t:=t+'\par \plain\f4\fs24 '+L[a]+'\plain\f'+IntToStr(a+5)+'\fs24 \tab Norm\''e1ln\''ed\tab \plain\f'+IntToStr(a+5)+'\fs24\b Tu\''e8n\''e9\plain\f\fs24 \tab \plain\f'+IntToStr(a+5)+'\fs24\i Kurs\''edva\plain\f'+IntToStr(a+5)+'\fs24 \tab \plain\f'+IntToStr(a+5)+'\fs24\b\i Tu\''e8n\''e1 kurs\''edva\plain\f'+IntToStr(a+5)+'\fs24'+#13+#10;
  58.   ProgressBar1.Position:=a;
  59.   Label2.Caption:=IntToStr(a+1)+' / '+IntToStr(Screen.Fonts.Count);
  60.   Application.ProcessMessages;
  61.   if StopAction then Break;
  62.  end;
  63.  r:=r+'}'+#13+#10;
  64.  t:=t+'\par }';
  65.  AssignFile(tf,OutFile);
  66.  Rewrite(tf);
  67.  Write(tf,r,t);
  68.  CloseFile(tf);
  69.  L.Free;
  70.  ProgressBar1.Position:=0;
  71.  Label2.Caption:='NaΦteno '+IntToStr(a)+' font∙';
  72.  Button1.Caption:='Start';
  73. end;
  74.  
  75. procedure TFontForm.FormShow(Sender: TObject);
  76. begin
  77.  if SaveDialog1.Execute then OutFile:=SaveDialog1.FileName
  78.   else Application.Terminate;
  79. end;
  80.  
  81. end.
  82.