完整範例 - Fontlist (10/10)

　　以下是FontList的完整代碼：

FontList.dpr顯示代碼

program FontList;

uses
  Forms,
  fontu in 'fontu.pas' {Form1};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.

fontu.dfm顯示代碼

object Form1: TForm1
  Left = 264
  Top = 210
  Width = 600
  Height = 500
  Caption = 'Fontlist'
  Color = clBtnFace
  Constraints.MinHeight = 400
  Constraints.MinWidth = 500
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  Position = poDesktopCenter
  Scaled = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  OnResize = FormResize
  PixelsPerInch = 96
  TextHeight = 13
  object Grid: TDrawGrid
    Left = 8
    Top = 50
    Width = 576
    Height = 412
    ColCount = 1
    FixedCols = 0
    FixedRows = 0
    GridLineWidth = 0
    Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goThumbTracking]
    ScrollBars = ssVertical
    TabOrder = 0
    OnDrawCell = GridDrawCell
  end
  object btnSystem: TButton
    Left = 8
    Top = 8
    Width = 84
    Height = 25
    Caption = 'System fonts'
    Enabled = False
    TabOrder = 1
    OnClick = btnSystemClick
  end
  object btnFolder: TButton
    Left = 108
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Font from folder'
    TabOrder = 2
    OnClick = btnFolderClick
  end
  object btnSelectFolder: TButton
    Left = 208
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Select folder'
    Enabled = False
    TabOrder = 3
    OnClick = btnSelectFolderClick
  end
  object btnSaveBmp: TButton
    Left = 308
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Save as bmp'
    TabOrder = 4
    OnClick = btnSaveBmpClick
  end
  object btnClose: TButton
    Left = 408
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Close'
    TabOrder = 5
    OnClick = btnCloseClick
  end
  object SavePictureDialog1: TSavePictureDialog
    DefaultExt = 'bmp'
    Options = [ofOverwritePrompt, ofPathMustExist, ofEnableSizing]
    Left = 504
    Top = 8
  end
end

fontu.pas隱藏代碼

unit Fontu;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, ExtDlgs;

type
  tFontData = record
    Filename, Fontname: string;
    Charset: integer;
  end;
  tFontDatas= array of tFontData;

  TForm1 = class(TForm)
    btnSystem: TButton;
    btnFolder: TButton;
    btnSelectFolder: TButton;
    btnSaveBmp: TButton;
    btnClose: TButton;
    Grid: TDrawGrid;
    SavePictureDialog1: TSavePictureDialog;
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure btnSystemClick(Sender: TObject);
    procedure btnFolderClick(Sender: TObject);
    procedure btnSelectFolderClick(Sender: TObject);
    procedure btnSaveBmpClick(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure GridDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormDestroy(Sender: TObject);
  private
    FSystemFonts: tFontDatas;
    FFolderFonts: tFontDatas;
    FFonts: ^tFontDatas;
    FFolder: String;
    FShowSystemFont: Boolean;
    procedure SetFolder(const Value: String);
    procedure SetShowSystemFont(const Value: Boolean);

    procedure DrawCell(Canvas: tCanvas; Rect: tRect; Row: integer; Selected: boolean);

    function  SelectFolder: string;
    procedure GetSystemFonts;
    procedure GetFolderFonts;
    procedure RemovePrivateFonts;
    procedure UpdateFonts;
    procedure SaveAsBitmap(const Filename: string);
  public
    property Folder: String read FFolder write SetFolder;
    property ShowSystemFont: Boolean read FShowSystemFont write SetShowSystemFont;
  end;

var
  Form1: TForm1;

implementation

uses
  ShlObj, ActiveX;
{$R *.DFM}                                              

const
  FontBgColorHl = clNavy;
  FontBgColor0  = $00d0eFFF;
  FontBgColor1  = $00eFd0FF;
  FontColorHl   = clWhite;
  FontColor0    = clBlack;
  FontColor1    = clBlack;
  LineHeight1   = 18;
  LineHeight2   = 24;
  LineHeight3   = 18;
  LineSpace1    = 2;
  LineSpace2    = 1;
  SpaceLeft     = 2;
  SpaceMiddle   = 1;
  FirstLineFont = 'Tahoma';
  DefaultSample = 'ABCDEFGabcdefg0123456789+-*/&=(){}<>,.?%$#';
  FontParam     = FR_PRIVATE;


function CharsetName(Charset: integer): string;
begin
  case charset of
    CHINESEBIG5_CHARSET: Result:='Chinese Big5';
    GB2312_CHARSET:      Result:='Chinese GB';
    ANSI_CHARSET:        Result:='Ansi';
    DEFAULT_CHARSET:     Result:='Default';
    SYMBOL_CHARSET:      Result:='Symbol';
    SHIFTJIS_CHARSET:    Result:='Janpanese ShiftJIS';
    HANGEUL_CHARSET:     Result:='Korean Hanguel';
    OEM_CHARSET:         Result:='OEM';
    JOHAB_CHARSET:       Result:='Johab';
    HEBREW_CHARSET:      Result:='Hebrew: ';
    ARABIC_CHARSET:      Result:='Arabic';
    GREEK_CHARSET:       Result:='Greek';
    TURKISH_CHARSET:     Result:='Turkish';
    VIETNAMESE_CHARSET:  Result:='Vietnamese';
    THAI_CHARSET:        Result:='Thai';
    EASTEUROPE_CHARSET:  Result:='East Europe';
    RUSSIAN_CHARSET:     Result:='Russian';
    BALTIC_CHARSET:      Result:='Baltic';
    MAC_CHARSET:         Result:='MAC';
    else                 Result:='Unknown';
  end
end;

procedure GetSampleText(Charset: integer; var Head, Str1, Str2: string);
begin
  case Charset of
    CHINESEBIG5_CHARSET: Head:='詩中天';
    GB2312_CHARSET:      Head:='坅笢毞';
    SHIFTJIS_CHARSET:    Head:=#$90#$9f#138;C';
    HANGEUL_CHARSET:     Head:='憡臐';
    else Head:='';
  end;
  case Charset of
    CHINESEBIG5_CHARSET: Str1:='地闊，一卷與君遊。－－歸木淡';
    GB2312_CHARSET:      Str1:='華屨ㄛ珨橙迵澱蚔﹝ㄜㄜ寥躂筏';
    SHIFTJIS_CHARSET:    Str1:=''#$95#$97''#$8d#$81'';
    HANGEUL_CHARSET:     Str1:='夥塋擎 離紫 曖 翎擎 霤腎橫塭';
    else Str1:='';
  end;
  Str2:=DefaultSample;
end;

var
  StartDirectryCallBack: string='';

function BrowseDialogCallBack (Wnd: HWND; uMsg: UINT; _lParam, _lpData: LPARAM):
  integer stdcall;  // Called back by BrowseDirectory
var
  wa, rect: TRect;
  dialogPT: TPoint;
begin
  if uMsg=BFFM_INITIALIZED then
  begin
    SystemParametersInfo(SPI_GETWORKAREA, 0, @wa, 0);
    GetWindowRect(Wnd, Rect);
    dialogPT.X:=((wa.Right-wa.Left) div 2) -
                ((rect.Right-rect.Left) div 2);
    dialogPT.Y:=((wa.Bottom-wa.Top) div 2) -
                ((rect.Bottom-rect.Top) div 2);
    MoveWindow(Wnd, dialogPT.X, dialogPT.Y,
               Rect.Right-Rect.Left, Rect.Bottom-Rect.Top, True);
    if StartDirectryCallBack<>'' then
      SendMessage(Wnd,BFFM_SETSELECTION, 1, Integer(@StartDirectryCallBack[1]));
  end;
  Result:=0;
end;

function BrowseDirectory(const Caption: string; const Root: WideString;
  var Directory: string): Boolean;
var
  WindowList: Pointer;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
begin
  Result:=False;
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc)=S_OK) and (ShellMalloc<>nil) then
  begin
    Buffer:=ShellMalloc.Alloc(MAX_PATH);
    try
      RootItemIDList:=nil;
      if Root <> '' then
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end;
      with BrowseInfo do
      begin
        hwndOwner:=Application.Handle;
        pidlRoot:=RootItemIDList;
        pszDisplayName:=Buffer;
        lpszTitle:=PChar(Caption);
        ulFlags:=BIF_RETURNONLYFSDIRS;
        lpfn:=BrowseDialogCallBack;
        StartDirectryCallBack:=Directory;
      end;
      WindowList:=DisableTaskWindows(0);
      try
        ItemIDList:=ShBrowseForFolder(BrowseInfo);
      finally
        EnableTaskWindows(WindowList);
      end;
      Result:= ItemIDList<>nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory:=Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

function NewStringListItem(const S1, S2: tStrings): string;
var
  i: integer;
begin
  result:='';
  if s2.count<=s1.count then exit;
  for i:=0 to s2.Count-1 do
    if (s2[i]<>'') and (s2[i][1]<>'@') and (s1.IndexOf(s2[i])<0) then
    begin
      result:=s2[i];
      exit;
    end;
end;

// Published methods

procedure TForm1.FormCreate(Sender: TObject);
begin
  Grid.ColWidths[0]:=Grid.ClientWidth;
  Grid.DefaultRowHeight:=LineHeight1+LineHeight2+LineHeight3+LineSpace1+LineSpace2;
  FFolder:='';
  SetLength(FFolderFonts,0);
  GetSystemFonts;
  FShowSystemFont:=false;
  ShowSystemFont:=true;
  Grid.DoubleBuffered:=true;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  RemovePrivateFonts;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Grid.SetBounds(Grid.Left, Grid.Top, ClientWidth-16, ClientHeight-Grid.Top-8);
  Grid.ColWidths[0]:=Grid.ClientWidth;
end;

procedure TForm1.btnSystemClick(Sender: TObject);
begin
  ShowSystemFont:=true;
end;

procedure TForm1.btnFolderClick(Sender: TObject);
begin
  ShowSystemFont:=false;
end;

procedure TForm1.btnSelectFolderClick(Sender: TObject);
begin
  Folder:=SelectFolder;
end;

procedure TForm1.btnSaveBmpClick(Sender: TObject);
begin
  if SavePictureDialog1.Execute then
    SaveAsBitmap(SavePictureDialog1.Filename)
end;

procedure TForm1.btnCloseClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.GridDrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
begin
  DrawCell(Grid.Canvas, Rect, ARow, gdSelected in State);
end;

// Private methods

procedure TForm1.SetFolder(const Value: String);
begin
  if Value='' then exit;
  FFolder:=Value;
  GetFolderFonts;
  if not ShowSystemFont then
  begin
    FFonts:=@FFolderFonts;
    UpdateFonts;
  end;
end;

procedure TForm1.SetShowSystemFont(const Value: Boolean);
begin
  if FShowSystemFont=Value then exit;
  if not Value then
  begin
    if FFolder='' then Folder:=SelectFolder;
    if FFolder='' then exit;
  end;

  FShowSystemFont:=Value;
  btnSystem.enabled:=not FShowSystemFont;
  btnFolder.enabled:=FShowSystemFont;
  btnSelectFolder.enabled:=not FShowSystemFont;
  if FShowSystemFont
    then Caption:='Fontlist - System fonts'
    else Caption:=format('Fontlist - Fonts in "%s"',[FFolder]);

  if FShowSystemFont
    then FFonts:=@FSystemFonts
    else FFonts:=@FFolderFonts;
  UpdateFonts;
end;

procedure TForm1.DrawCell(Canvas: tCanvas; Rect: tRect; Row: integer;
  Selected: boolean);   //Gridwidth changed to be 0
var
  HeadStr, Str1, Str2: string;
  p: tPoint;
  w: integer;
begin
  with Canvas do
  begin
    if Selected
       then Brush.Color:=FontBgColorHl
       else if Row mod 2=0
         then Brush.Color:=FontBgColor0
         else Brush.Color:=FontBgColor1;
    FillRect(rect);
    if Row>=Length(fFonts^) then exit;

    if Selected
       then Font.Color:=FontColorHl
       else if Row mod 2=0
         then Font.Color:=FontColor0
         else Font.Color:=FontColor1;
    SetBkMode(Handle, TRANSPARENT);
    Font.Name:=FirstLineFont;
    Font.Charset:=DEFAULT_CHARSET;
    Font.Height:=LineHeight1;

    P:=Rect.TopLeft;
    inc(p.x, SpaceLeft);
    HeadStr:='Charset: '+CharsetName(fFonts^[Row].Charset);
    if fFontS^[Row].Filename<>'' then
      HeadStr:=ExtractFilename(fFonts^[Row].Filename)+', '+HeadStr;
    HeadStr:=fFonts^[Row].Fontname+' ('+HeadStr+')';
    Textout(p.x, p.y, HeadStr);

    Font.Name:=fFonts^[Row].Fontname;
    inc(p.y, LineHeight1+LineSpace1);
    Font.Charset:=fFonts^[Row].Charset;

    GetSampleText(fFonts^[Row].Charset, HeadStr, Str1, Str2);
    if (Str1='') or (Str2='') then
    begin
      HeadStr:=HeadStr+Str1+Str2;
      Str1:='';
      Str2:='';
    end;

    if HeadStr<>'' then
    begin
      Font.Height:=LineHeight2+LineSpace2+LineHeight3;
      Textout(p.x ,p.y, HeadStr);
      Inc(p.x, SpaceMiddle+TextWidth(Headstr));
    end;

    if Str1<>'' then
    begin
      Font.Height:=LineHeight2;
      Textout(p.x, p.y, Str1);
    end;

    if Str2<>'' then
    begin
      Inc(p.y, LineHeight2+LineSpace2);
      Font.Height:=LineHeight3;
      Textout(p.x, p.y, Str2);
    end;
  end;
end;

function TForm1.SelectFolder: string;
begin
  Result:=FFolder;
  if not BrowseDirectory('Please select a font folder', '', result)
    then result:='';
end;

procedure TForm1.GetSystemFonts;
var
  i, l: integer;
  OldFont: tFont;
  tm: tagTEXTMETRICA;
begin
  SetLength(fSystemFonts,Screen.Fonts.Count);
  l:=0;
  OldFont:=tFont.Create;
  OldFont.Assign(Canvas.Font);
  try
    for i:=0 to Screen.Fonts.Count-1 do
      if Screen.Fonts[i][1]<>'@' then
      begin
        fSystemFonts[l].Fontname:=Screen.Fonts[i];
        fSystemFonts[l].Filename:='';
        Canvas.Font.Name:=fSystemFonts[l].Fontname;
        GetTextMetrics(Canvas.Handle, tm);
        fSystemFonts[l].Charset:=tm.tmCharSet;
        inc(l);
      end;
  Finally
    SetLength(fSystemFonts,l);
    Canvas.Font.Assign(OldFont);
    OldFont.Free;
  end;
end;

procedure TForm1.GetFolderFonts;
var
  OldFont: tFont;
  s1, s2: tstringlist;

  procedure AddFiles(const Path, Ext: string);
  var
    sr: tSearchRec;
    tm: tagTEXTMETRICA;
    fd: tFontData;
    i,j,l: integer;
  begin
    if FindFirst(Path+Ext, faAnyFile, sr)=0 then
      repeat
        s1.Assign(Screen.Fonts);
        fd.Filename:=Path+sr.Name;
        AddFontResourceEx(pchar(fd.Filename), FontParam, nil) ;
        SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
        s2.Assign(Screen.Fonts);
        fd.Fontname:=NewStringListItem(s1, s2);
        if fd.Fontname<>'' then
        begin
          Canvas.Font.Name:=fd.Fontname;
          GetTextMetrics(Canvas.Handle, tm);
          fd.Charset:=tm.tmCharSet;

          l:=length(fFolderFonts);
          setlength(fFolderFonts,l+1);
          fFolderFonts[l]:=fd;
        end else
        begin
          RemoveFontResourceEx(pchar(fd.Filename), FontParam, nil) ;
          SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
        end;
      until FindNext(sr)<>0;
    FindClose(sr);
  end;

begin
  RemovePrivateFonts;
  OldFont:=tFont.Create;
  OldFont.Assign(Canvas.Font);
  s1:=tStringList.Create;
  s2:=tStringList.Create;
  try
    AddFiles(IncludeTrailingBackslash(FFolder), '*.tt*');
    AddFiles(IncludeTrailingBackslash(FFolder), '*.fon');
    AddFiles(IncludeTrailingBackslash(FFolder), '*.otf');
  finally
    s1.Free;
    s2.Free;
    Canvas.Font.Assign(OldFont);
    OldFont.Free;
  end;
end;

procedure TForm1.RemovePrivateFonts;
var
  i: integer;
begin
  for i:=0 to length(fFolderFonts)-1 do
    RemoveFontResourceEx(pchar(fFolderFonts[i].Filename), FontParam, nil) ;
  SetLength(fFolderFonts, 0);
  SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;
end;

procedure TForm1.UpdateFonts;
begin
  btnSavebmp.enabled:=length(FFonts^)>0;
  Grid.RowCount:=length(FFonts^);
  Grid.Invalidate;
end;

procedure TForm1.SaveAsBitmap(const Filename: string);
var
  bmp: tbitmap;
  i, w, lh: integer;
begin
  bmp:=tBitmap.Create;
  w:=Grid.ClientWidth;
  lh:=Grid.DefaultRowHeight;
  try
    bmp.Width:=w;
    bmp.Height:=lh*length(FFonts^);
    for i:=0 to length(FFonts^)-1 do
      DrawCell(bmp.Canvas, Rect(0, i*lh, w, (i+1)*lh), i, false);
    bmp.SaveToFile(Filename);
  finally
    bmp.Free;
  end;
end;

end.