完整範例 - 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.

閱讀全文......

完整範例 - Fontlist (9/10)

　　GetFolderFonts是處理目錄字型的核心，它負責讀取字型檔案、載入字型、求得字型名稱和卸載字型。因為字型檔有多種，所以這些功能由子程序AddFiles完成，GetFolderFonts多次呼叫AddFiles以處理不同的字型檔。

　　GetFolderFonts的第一步，是由RemovePrivateFonts卸裝之前安裝的目錄字型和清空fFolderFonts。然後它創建了兩個在AddFiles中要使用的TStringList和保存了Canvas.Font。並在呼叫AddFiles後放回舊值。

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;

　　AddFiles使用FindFirst/FindNext找出所有檔案，對每一個檔案它用AddFontResourceEx嘗試安裝，用SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0) ;使系統告知其它程序（如使Delphi程序更新Screen.Fonts），然後找出新增的字型。如果有新的字型則將之加入，否則放棄，並卸裝字型。注意RemoveFontResourceEx的參數必須和AddFontResourceEx完全相同，在此我們使用了常量FontParam。FR_PRIVATE表示其他程序沒法使用我們安裝的字型。

const
  FontParam     = FR_PRIVATE;

　　NewStringListItem用來找出S2中第一個不存在於S1的字符串，它用了TStrings.IndexOf()。

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;

　　為甚麼我們用這樣一個方法求字型名稱？這是因為字型名稱和字型檔案並不一一對應，例如「細明體」和「新細明體」是同一個檔案，而Times New Romans有四個檔案。此外字型名稱受系統內碼影響，例如「細明體」在非繁體系統中變成了「PMingLiu」。為了避免考慮這些复雜的問題，我們只好使用這個無賴卻有效的做法。

　　字型的卸裝很容易，只要用RemoveFontResourceEx一一卸裝即可，然後把fFolderFonts清空即可。

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.FormDestroy(Sender: TObject);
begin
  RemovePrivateFonts;
end;

　　以下是顯示目錄字型的例子：

閱讀全文......

完整範例 - Fontlist (8/10)

　　到此為止，對系統字型的處理告一段落，剩下的是目錄字型的處理。首先，我們要讓使用者選擇目錄（SelectFolder），這是十分簡單的事：

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

　　如果把BrowseDirectory改成SelectDirectory，再加上uses FileCtrl;，本篇的內容便算完成了。但是因為SelectDirectory有很多缺點（SelectDirectory有兩種形式，其中一種是舊式的Win32式的界面，用來很覺別扭，另一種（SelectFolder（Caption, Root, Dir)）是Win NT的風格，但是它對話框出現的位置有時很奇怪，而且對話框出現時，選取的是根目錄(Root)，而不是舊目錄(Dir)，所以使用者每一次都要從設定的根目錄找起，這用起來十分煩人），為了程序員的尊嚴，我們當然不然讓這種缺點留著，所以我們使用了BrowseDirectory，它的代碼如下。

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;

　　BrowseDirectory和SelectDirectory所用的方法基本一樣，只是前者在Callback函數中調整了對話框的位置，以及選擇了舊目錄。代碼較長和复雜，不一一說明，有興趣的朋友可以自行研究。

閱讀全文......

完整範例 - Fontlist (7/10)

　　本篇的工作，是把字型樣本儲存成bmp檔案，雖然這像是一個全新的問題，但是實際上並不是，以下短短的幾行代碼便可以完成。

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;.

　　這裏的關鍵，是我們已經把DrawCell從GridDrawCell分離出來，使得它可以繪畫在不同的Canvas上。這是十分常見的技巧，除了可以減少工作量外，還可以保持輸出的一致性，代碼也更易維護。

　　Screen，graphic和printer的輸出雖然有若干不同之處，但是只要稍加注意，完全可以用相同的方法完成----畢竟它們都使用了tCanvas。

閱讀全文......

完整範例 - Fontlist (6/10)

　　本篇的目的，是讓顯示的樣本好看一點，這是因為我認為一行呆板的文字太難看，想加點變化。好聽點說，是對美有著基本的執著，不好聽，便是多此一舉。無論如何，把輸出變成下面的樣子，觀感的確是好很多。

　　我們的樣本分三行，第一行是字型名稱、文件名和charset，第二行是東亞字型樣本，第三行是ascii字型樣本，第二行和第三行的前半可以合併，顯示較大的文字。個人覺得這種設計很好看，它還很好利用了空間，能同時顯示中/英和不同大小的字，方便比較。

　　以下是相關的常量，三個行高、兩個行距和兩個水平間格。為了清晰起見，第一行用標準字體，否則有些手寫體根本連字型名稱也看不懂：

const
  LineHeight1   = 18;
  LineHeight2   = 24;
  LineHeight3   = 18;
  LineSpace1    = 2;
  LineSpace2    = 1;
  SpaceLeft     = 2;
  SpaceMiddle   = 1;
  FirstLineFont = 'Tahoma';
  DefaultSample = 'ABCDEFGabcdefg0123456789+-*/&=(){}<>,.?%$#';

　　定義常量，是王道。直接使用數值，對程序的修改維護很不利。

　　樣本變了，Grid列高當然要隨之改變：

procedure TForm1.FormCreate(Sender: TObject);
begin
  ....
  Grid.DefaultRowHeight:=LineHeight1+LineHeight2+LineHeight3+LineSpace1+LineSpace2;
  ....
end;

　　DrawCell頗有一些修改，關鍵是多了一個p: Tpoint;，用來標示文字的左上角，在印出文字後，我們便加上字寬或字高（用Canvas.TextWidth和Canvas.TextHeight）。

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;

　　為了避免复雜和增加可讀性，顯示的文字用CharsetName和GetSampleText求得。如果第二行和第三行有一行是空白的，則將之合併起來。

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;

　　兩行合併的例子。

閱讀全文......

完整範例 - Fontlist (5/10)

　　在上篇中我們雖然成功地繪畫出字型的樣本，但是有部分字型顯示得並不正常，例如下圖，SimHei（簡體中文系統所用的黑體）出現了一些怪字，Shruti顯示的字型也成了亂碼。究其原因，是因為我們所寫的是Ansi的程序，而不是Unicode的程序。Unicode的程序通用性十分優越，但是一直到Windows 2000才得到直接的支持，加上代碼較复雜，所以目前大部分程序仍然是Ansi的。Ansi程序用到的所有文字，顯示時都要考慮Charset，在delphi中，即是tFont.Charset。

　　Delphi中所有的字型，Charset都設為DEFAULT_CHARSET，即系統內定的值（設定方法：控制台→國家及語言→進階→非Unicode程序語言），將之設為CHINESEBIG5_CHARSET便是繁體中文所用的大五碼(Big5)，設為GB2312_CHARSET便是簡體系統所用的國家標準碼(GB/GBK)。

　　每一種字型，都有它支持的編碼，例如SimHei支持的是GB2312_CHARSET，將之以DEFAULT_CHARSET或CHINESEBIG5_CHARSET顯示便得到亂碼。因此，在繪畫時我們必須針對每一字型使用正確的Charset，為了方便，我們將之儲放在tFontData中：

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

　　然後在GetSystemFonts時求得Charset：

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;

　　上面代碼中的GetTextMetrics，是用來求得Charset的Win API，它需要一個TCanvas的Handle，我們使用了Form的Canvas.Font。為了避免Form的外貌受到影響，我們保存了舊的字型設定，並在最後復原。

　　DrawCell改變得並不多，只是在設定字型的時把Charset也改變，然後印出文字時使用相應內碼的文字串。

procedure TForm1.DrawCell(Canvas: tCanvas; Rect: tRect; Row: integer;
  Selected: boolean);   //Gridwidth changed to be 0
var
  s: string;
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:=fFonts^[Row].Fontname;
    Font.Charset:=fFonts^[Row].Charset;
    Font.Height:=Rect.Bottom-Rect.Top-4;
    case Font.Charset of
      CHINESEBIG5_CHARSET: s:='詩中天地闊。';
      GB2312_CHARSET: s:='坅笢毞華屨﹝';
      SHIFTJIS_CHARSET: s:=#$90#$9f''#$95#$97''#$8d#$81;
      HANGEUL_CHARSET: s:='憡臐夥塋擎';
      else s:='A lazy fox.';
    end;
    Textout(Rect.Left+2, Rect.Top+2,
            s+fFonts^[Row].Fontname);
  end;
end;

　　內碼和Charset的對應是十分复雜問題，但是只是要印出幾行定的樣本文字並不難，我們只是加入了約二十行的代碼而已，看來卻好多了。

閱讀全文......

完整範例 - Fontlist (4/10)

　　因為目錄字型的處理比較复雜，所以我們暫時將它們放在一旁，首先著手處理系統字型。本篇及下兩篇將講解字型樣本的繪畫，然後將講解如何將字型樣本儲存成.bmp檔案。在所有功能都做好後，我們才著手處理目錄字型。而本篇的目標，便是能做到下圖的效果。

　　說目錄字型處理比較复雜，是因為我們必須找出該目錄的所有字型，將之載入，然後找出對應的字型名，與之相比，系統字型早已裝載，Delphi 甚至將它們封裝在Screen變量中，使用起來很方便。

procedure TForm1.GetSystemFonts;
var
  i, l: integer;
begin
  SetLength(fSystemFonts,Screen.Fonts.Count);
  l:=0;
  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:='';
      inc(l);
    end;
  SetLength(fSystemFonts,l);
end;

　　對於系統字型，文件名並不易求，我們只是簡單地把它們設為空白。這裏要注意的是大部分中文字型，例如細明體，在Screen.fonts中出現兩份，其中一個是「細明體」，另一個是「@細明體」，後者用於直排文字，在此沒有必要重复，所以全部忽略了。

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

　　UpdateFonts是字型改變後的處理，其實不多，只是相應改變Grid的列數和要求它重畫。

　　字型樣本繪畫在Grid上，要處理Grid的OnDrawCell，以下是其定義。

type
  TForm1 = class(TForm)
    ....
    procedure GridDrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
  private
    procedure DrawCell(Canvas: tCanvas; Rect: tRect; Row: integer; Selected: boolean);
    ....
  end;

　　GridDrawCell只是呼叫DrawCell，多了層轉折的原因，是為了多一層靈活性，以後將會解釋。

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

　　為了讓字型樣本足夠大，我們還需要在初始化時設定列高。同時，在Object Inspector中將Grid.GridWidth設為0，否則兩列之間有橫線。

procedure TForm1.FormCreate(Sender: TObject);
begin
  Grid.DefaultRowHeight:=32;
  Grid.DoubleBuffered:=true;
  ....
end;

　　DoubleBuffered:=true防止Grid閃爍。以下是真正的繪畫方法，首先是一些常量的定義：

const
  FontBgColorHl = clNavy;
  FontBgColor0  = $00d0eFFF;
  FontBgColor1  = $00eFd0FF;
  FontColorHl   = clWhite;
  FontColor0    = clBlack;
  FontColor1    = clBlack;

procedure TForm1.DrawCell(Canvas: tCanvas; Rect: tRect; Row: integer;
  Selected: boolean);
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:=fFonts^[Row].Fontname;
    Font.Height:=Rect.Bottom-Rect.Top-4;
    Textout(Rect.Left+2, Rect.Top+2,
            '詩中天地闊。Poem is lovely. - '+fFonts^[Row].Fontname);
  end;
end;

　　DrawCell首先根據是否被選中，以及列數奇偶設定背景色，填滿，然後改變文字的色彩和字型，最後打印出「詩中天地闊。Poem is lovely.」及字型名稱。這裏有兩點應該注意：1）SetBkMode(Handle, TRANSPARENT);使打印出來的文字沒有背景。2）我們使用了Font.Height而不是Font.Size，這是必須的。雖然Windows說在同一設備上兩者之間有固定比例，但是這是忽略了字型的External leading的情況，如下圖，如果設定的是Font.Size，有些字便會超出格外。

　　基本上這便是我們本篇要做的工作，看來還不錯，不過有些字型顯示成亂碼了，讓我們在下一篇處理吧。

閱讀全文......

完整範例 - Fontlist (3/10)

　　在界面設計好後，我們便要對程序的實現進行一個整體規劃。雖然程序的功能總是一個一個加上去的，但是程序的整體思路卻應該儘早規劃，這可以為將來程序的發展預留空間，也可以避免大量修改原來代碼。

　　在 OOP 編程中，程序的規劃主要體現在 Object 上，以下是我們對所用 object 的定義：

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

  TForm1 = class(TForm)
    ....
    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);
    ....
  private
    FSystemFonts: tFontDatas;
    FFolderFonts: tFontDatas;
    FFonts: ^tFontDatas;
    FFolder: String;
    FShowSystemFont: Boolean;
    procedure SetFolder(const Value: String);
    procedure SetShowSystemFont(const Value: Boolean);

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

　　在這裏我們增加了對四個TButton被按下時的處理，以及FormCreate、FormResize的處理。我們還增加了ShowSystemFont、Folder兩個屬性，前者表示顯示的是系統字型還是目錄內字錄，後者指定字型所在目錄。

　　此外我們定義了三個tFontDatas相關的變量，顧名思義，FSystemFonts將會列出所有系統字型，FFolderFonts則是Folder內的字型。FFonts指向目前所用的tFontDatas，可以指向FFolderFonts或FSystemFonts，視ShowSystemFont而定。以後我們的操作將通過此指針完成，這樣可以大大簡化代碼，不必因為ShowSystemFont不同而分開處理。

　　最後還有五個private函數，它們都是未完成的部分，在下面會一一細說。

procedure TForm1.FormCreate(Sender: TObject);
begin
  Grid.ColWidths[0]:=Grid.ClientWidth;
  FFolder:='';
  SetLength(FFolderFonts,0);
  GetSystemFonts;
  FShowSystemFont:=false;
  ShowSystemFont:=true;
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;

　　FormCreate是一些簡單的初始化。第2、3、5行都是多餘的，因為這本來便是初始化的值。第一行是改變欄寬，盡量使用所有空間，第4行呼叫GetSystemFonts取得所有系統字型，第6行則設定屬性使之顯示系統字型。

　　使用者改變form的大小時，FormResize使Grid的大小和欄寬隨之改變。這是運行時載圖。

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;

　　對TButton的處理，實在簡單得很，只是把相關屬性設定便可以了，簡潔明瞭，這便是 OOP 的好處。這裏用到兩個函數，分別是SelectFolder和SaveAsBitmap，前者的功能是要求使用者選擇目錄（目錄如果是空白表示使用者按了「取消」鍵），後者則把目前的字型樣本儲成.bmp檔案。相應地，我們在 form 中增加了一個tSavePictureDialog。

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;

　　這部分是主篇的重點，它處理了ShowSystemFont和Folder兩個屬性改變時，程序所作出的反應。當Folder變化時，我們要做的東西比較少，首先是我們要讀取Folder內的字型（GetFolderFonts），其次是如果ShowSystemFont是false時，表示目前顯示的是目錄下的字型，我們便要更新顯示的字型（UpdateFonts）。

　　SetShowSystemFont長一點點，首先如果顯示目錄字型而目錄尚未設定，它會要求使用者選擇目錄，否則便顯示系統字型。然後它會把不適用的TButton禁用和改變標題。最後它會設定合適的tFontDatas，然後更新顯示的字型。

function TForm1.SelectFolder: string;
begin
  result:='c:\';
end;

procedure TForm1.GetSystemFonts;
begin

end;

procedure TForm1.GetFolderFonts;
begin

end;

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

procedure TForm1.SaveAsBitmap(const Filename: string);
begin

end;

end.

　　以上是未完成的部分，實際上是程序的真正核心。不過雖然核心部分幾乎全是空白，程序的架構卻已經完整了。

　　下面是完整的pas代碼。

fontu.pas顯示代碼

unit Fontu;

interface

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

type
  tFontData = record
    Filename, Fontname: string;
  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);
  private
    FSystemFonts: tFontDatas;
    FFolderFonts: tFontDatas;
    FFonts: ^tFontDatas;
    FFolder: String;
    FShowSystemFont: Boolean;
    procedure SetFolder(const Value: String);
    procedure SetShowSystemFont(const Value: Boolean);

    function  SelectFolder: string;
    procedure GetSystemFonts;
    procedure GetFolderFonts;
    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

{$R *.DFM}

// Published methods

procedure TForm1.FormCreate(Sender: TObject);
begin
  Grid.ColWidths[0]:=Grid.ClientWidth;
  FFolder:='';
  SetLength(FFolderFonts,0);
  GetSystemFonts;
  FShowSystemFont:=false;
  ShowSystemFont:=true;
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;

// 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;

function TForm1.SelectFolder: string;
begin
  result:='c:\';
end;

procedure TForm1.GetSystemFonts;
begin

end;

procedure TForm1.GetFolderFonts;
begin

end;

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

procedure TForm1.SaveAsBitmap(const Filename: string);
begin

end;

end.

閱讀全文......

完整範例 - Fontlist (2/10)

　　就如一般的Delphi程序，我們要做的第一件事就是設計使用者界面。Fontlist的功能並不复雜，所以使用界面很簡單，我們只需要五個TButton和一個TDrawGrid，字型的樣本將顯示在TDrawGrid上。使用TDrawGrid並沒有特別的原因，改用TListBox可以。

　　界面的截圖和dfm文件如下：

fontu.dfm顯示代碼

object Form1: TForm1
  Left = 200
  Top = 150
  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
  PixelsPerInch = 96
  TextHeight = 13
  object Grid: TDrawGrid
    Left = 8
    Top = 50
    Width = 576
    Height = 412
    ColCount = 1
    FixedCols = 0
    Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goThumbTracking]
    FixedRows = 0
    ScrollBars = ssVertical
    TabOrder = 0
  end
  object btnSystem: TButton
    Left = 8
    Top = 8
    Width = 84
    Height = 25
    Caption = 'System fonts'
    Enabled = False
    TabOrder = 1
  end
  object btnFolder: TButton
    Left = 108
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Font from folder'
    TabOrder = 2
  end
  object btnSelectFolder: TButton
    Left = 208
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Select folder'
    Enabled = False
    TabOrder = 3
  end
  object btnSaveBmp: TButton
    Left = 308
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Save as bmp'
    TabOrder = 4
  end
  object btnClose: TButton
    Left = 408
    Top = 8
    Width = 84
    Height = 25
    Caption = 'Close'
    TabOrder = 5
    OnClick = btnCloseClick
  end
end

　　這時我們仍然未有多少代碼，只是簡單地加上了退出的功能：procedure btnCloseClick(Sender: TObject);。

fontu.pas隱藏代碼

unit Fontu;

interface

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

type
  TForm1 = class(TForm)
    btnSystem: TButton;
    btnFolder: TButton;
    btnSelectFolder: TButton;
    btnSaveBmp: TButton;
    btnClose: TButton;
    Grid: TDrawGrid;
    procedure btnCloseClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

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

end.

　　FontList.dpr由Delphi自動產生，沒有任何變動。

FontList.dpr隱藏代碼

program FontList;

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

{$R *.RES}

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

閱讀全文......

完整範例 - Fontlist (1/10)

　　這是Code²的第一篇文章，也是第一個完整的範例。在這個範例裏，我們將完成一個完整的Delphi程序，這個程序可以顯示所有的系統字型，也可以列出指定目錄下的所有字型，此外我們還希望可以把顯示的字型存成bmp文件。聽來雖然复雜，但是如果掌握了相關的Windows API，這其實並不是太難的題目。以下是最終作品的截圖。

　　這是一個不算大的程序，共有500多行，除了Windows API，還有涉及Canvas的繪畫，對Delphi函數SelectDirectory的改善等等，將在此後的8篇文章中一一說明。此系列的最後一篇則是完整的代碼。

1. 本目錄
2. 界面設計
3. 程序基本架構
4. 系統字型及繪畫樣本文字
5. Charset處理
6. 進階文字繪畫
7. 儲存Bitmap
8. SelectDirectory的改進
9. 目錄字型處理
10. 最終代碼

閱讀全文......