如何接受拖放文件

　　在Delphi中接受拖放並不難，只要在FormCreate說明一下，然後處理WM_DROPFILES就可以了，以下是簡單的例子。

Type
  tFiles = array of string;
  TForm1 = class(TForm)
  ...
  private
    procedure OnAcceptfiles(Sender: tobject; var Files: tFiles);
    procedure AcceptFiles(var msg : TMessage); message WM_DROPFILES;
    ...
  end;

...

implementation

uses
  ShellAPI;

procedure TForm1.FormCreate(Sender: TObject);
begin
  DragAcceptFiles(Handle, True);
end;

procedure TPoemForm.AcceptFiles(var msg: TMessage);
const
  cnMaxFileNameLen = 255;
var
  i, n: integer;
  acFileName: array [0..cnMaxFileNameLen] of char;
  Files: tFiles;
begin
  // 首先求得檔案數目
  n:=DragQueryFile(msg.WParam, $FFFFFFFF, acFileName, cnMaxFileNameLen);
  Setlength(Files, n);
  try
    // 遂一求得檔案名
    for i:=0 to n-1 do
    begin
      DragQueryFile(msg.WParam, i, acFileName, cnMaxFileNameLen);
      Files[i]:=acFileName;
    end;
  finally
    // 結束拖放處理
    DragFinish(msg.WParam);
  end;
  if n>0 then 
    OnAcceptfiles(Self, Files);
end;

procedure TPoemForm.OnAcceptfiles(Sender: tobject; var Files: tFiles);
begin
  // 做想做的事
end;

....

end.

　　上面例子中整個Form都可接受拖放文件，如果想只要Form的一部分接受文件，改變DragAcceptFiles所用的Handle即可，也可以多次使用DragAcceptFiles，使得多個控制元件接受拖放。

閱讀全文......

打印機的大小及分辨率

　　使用GetDeviceCaps可以求得各種設備的大小，以下把它做成了OBJECT，方便使用：

interface

uses
  windows，Classes;

type
  TDeviceCaps=class
  private
    fHandle: tHandle;
    function GetCapabilities(i: integer): integer;
  public
    constructor Create(h: thandle);
    property Handle: tHandle read fHandle write fHandle;
    property Capabilities[i: integer]: integer read GetCapabilities;
    property Driver_Version: integer index windows.DRIVERVERSION read GetCapabilities;
    property Technology: integer index windows.TECHNOLOGY read GetCapabilities;
    property X_SizeMM: integer index windows.HORZSIZE read GetCapabilities;            // in mm
    property Y_SizeMM: integer index windows.VERTSIZE read GetCapabilities;
    property X_Size: integer index windows.HORZRES read GetCapabilities;       // in pixels
    property Y_Size: integer index windows.VERTRES read GetCapabilities;
    property X_LogPixel: integer index windows.LOGPIXELSX read GetCapabilities;      // in dpi
    property Y_LogPixel: integer index windows.LOGPIXELSY read GetCapabilities;
    property X_PhysicalSize: integer index windows.PHYSICALWIDTH read GetCapabilities;   // in pixels
    property Y_PhysicalSize: integer index windows.PHYSICALHEIGHT read GetCapabilities;
    property X_PhysicalOffset: integer index windows.PHYSICALOFFSETX read GetCapabilities;   // in pixels
    property Y_PhysicalOffset: integer index windows.PHYSICALOFFSETY read GetCapabilities;
  end;

implementation

constructor TDeviceCaps.Create(h: thandle);
begin
  fHandle:=h;
end;

function TDeviceCaps.GetCapabilities(i: integer): integer;
begin
  result:=GetDeviceCaps(fHandle,i);
end;

使用方法如下：

var
  PrinterDev: tDeviceCaps;

....
  PrinterDev:=tDeviceCaps.Create(printer.handle);
  Xdpi    :=PrinterDev.X_LogPixel;
....

閱讀全文......

關於任務欄

　　想知道Taskbar是否可見，或者想隱藏它，可以用以下Windows API：

function IsTaskBarVisible: boolean;
var
  wndHandle : THandle;
  wndClass  : array[0..50] of Char;
begin
  StrPCopy(@wndClass[0], 'Shell_TrayWnd');
  wndHandle := FindWindow(@wndClass[0], nil);
  result := ShowWindow(wndHandle, SW_SHOWNA);
end;

procedure HideTaskBar;
var
  wndHandle : THandle;
  wndClass  : array[0..50] of Char;
begin
 StrPCopy(@wndClass[0], 'Shell_TrayWnd');
 wndHandle := FindWindow(@wndClass[0], nil);
 ShowWindow(wndHandle, SW_HIDE);
end;

procedure ShowTaskBar;
var wndHandle : THandle;
  wndClass  : array[0..50] of Char;
begin
 StrPCopy(@wndClass[0], 'Shell_TrayWnd');
 wndHandle := FindWindow(@wndClass[0], nil);
 ShowWindow(wndHandle, SW_RESTORE);
end;

閱讀全文......

取得檔案最後修改時間

　　要知道一個檔案文件是否曾被修改，一個方便的方法是看看它的最後修改日期，Delphi提供了兩個和文件日期有關的函數：FileAge和FileGetDate，但是它們返回的都是文件建立的時間而不是最後修改的時間。

　　Windows中每一個文件有三個時間屬性，建立時間、最後打開時間和最後修改時間，可以用下列函數取得：

function  TFileTime2DateTime(Time: TFileTime): tDatetime;
var
  LocalTime: TFileTime;
  DosTime: Integer;
begin
  FileTimeToLocalFileTime(Time, LocalTime);
  FileTimeToDosDateTime(LocalTime, LongRec(DosTime).Hi, LongRec(DosTime).Lo);
  Result:=FileDateToDateTime(DosTime);
end;

function  DateTime2TFileTime(Time: tDatetime): TFileTime;
var
  LocalTime: TFileTime;
  DosTime: Integer;
begin
  DosTime:=DateTimeToFileDate(Time);
  DosDateTimeToFileTime(LongRec(DosTime).Hi, LongRec(DosTime).Lo, LocalTime);
  LocalFileTimeToFileTime(LocalTime, Result);
end;

function  GetFileCreationTime(const filename:string): tdatetime;
var
  hFile: THandle;
  FileTime: TFileTime;
begin
  hFile:=FileOpen(filename, fmOpenRead);
  try
    GetFileTime(hFile, @FileTime, nil, nil);
    Result:=TFileTime2DateTime(FileTime);
  finally
    FileClose(hFile);
  end;
end;

function  GetFileLastAccessTime(const filename:string): tdatetime;
var
  hFile: THandle;
  FileTime: TFileTime;
begin
  hFile:=FileOpen(filename, fmOpenRead);
  try
    GetFileTime(hFile, nil, @FileTime, nil);
    Result:=TFileTime2DateTime(FileTime);
  finally
    FileClose(hFile);
  end;
end;

function  GetFileLastWriteTime(const filename:string): tdatetime;
var
  hFile: THandle;
  FileTime: TFileTime;
begin
  hFile:=FileOpen(filename, fmOpenRead);
  try
    GetFileTime(hFile, nil, nil, @FileTime);
    Result:=TFileTime2DateTime(FileTime);
  finally
    FileClose(hFile);
  end;
end;

閱讀全文......

复制中文文字到剪貼板

在Delphi中把文字复制到剪貼板是很容易的，只要Uses clipbrd;後設定Clipboard.AsText即可，但是如果文字中使用了非ASCII字元，在不同語言的系統中將出現亂碼，解決的方法是复制時說明文字的編碼：

procedure CopyToClipboard(const s: string; LocaleID: LCID = $0404);
var
  MemHandle: HGLOBAL;
  P: ^LCID;
begin
  if s='' then exit;
  with Clipboard do
  begin
    MemHandle:=GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, sizeof(LCID));
    if MemHandle <> 0 then
    begin
      p:=GlobalLock(MemHandle);
      p^:=LocaleID;
      GlobalUnlock(MemHandle);
      Open;
      try
        AsText := s;
        SetAsHandle(CF_Locale, MemHandle);
      finally
        Close;
      end;
    end else astext:=s;
  end;
end;

當然，也可以使用Unicode：

procedure CopyToClipBoardw(const ws: widestring);
var
  MemHandle: HGLOBAL;
  ptr: ^LCID;
begin
  MemHandle := GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE, 2*length(ws)+2);
  if MemHandle <> 0 then
  begin
    ptr:=GlobalLock(MemHandle);
    Move(PWideChar(ws)^, ptr^, 2*length(ws)+2);
    GlobalUnlock(MemHandle);
    Clipboard.SetAsHandle(CF_UNICODETEXT, MemHandle);
  end;
end;

閱讀全文......

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

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

閱讀全文......