createfontu.pas

DelphiWin32核心API参考光盘内容.是学习书籍中的源码,便于学习.

unit CreateFontU;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormPaint(Sender: TObject);
var
  NewFont, OldFont: HFont;     // holds the old and new fonts
begin
  {set the background mode for transparency}
  SetBkMode(Form1.Canvas.Handle, TRANSPARENT);

  {create a bold font}
  NewFont := CreateFont(-MulDiv(16, GetDeviceCaps(Form1.Canvas.Handle,
                        LOGPIXELSY), 72), 0, 0, 0, FW_BOLD, 0, 0, 0,
                        DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS,
                        CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH or
                        FF_DONTCARE, 'Arial');

  {select the font into the form's device context}
  OldFont := SelectObject(Form1.Canvas.Handle, NewFont);

  {output a line of text}
  TextOut(Form1.Canvas.Handle, 8, Label1.Top+Label1.Height, 'Delphi Rocks!',
          Length('Delphi Rocks!'));

  {select the old font back into the device context and delete the new font}
  SelectObject(Form1.Canvas.Handle, OldFont);
  DeleteObject(NewFont);

  {create a strikeout font}
  NewFont := CreateFont(-MulDiv(16, GetDeviceCaps(Form1.Canvas.Handle,
                        LOGPIXELSY), 72), 0, 0, 0, FW_DONTCARE, 0, 0, 1,
                        DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS,
                        CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH or
                        FF_ROMAN, '');

  {select the font into the form's device context}
  OldFont := SelectObject(Form1.Canvas.Handle, NewFont);

  {output a line of text}
  TextOut(Form1.Canvas.Handle, 8, Label2.Top+Label2.Height, 'Delphi Rocks!',
          Length('Delphi Rocks!'));

  {select the old font back into the device context and delete the new font}
  SelectObject(Form1.Canvas.Handle, OldFont);
  DeleteObject(NewFont);

  {create an underlined font}
  NewFont := CreateFont(-MulDiv(16, GetDeviceCaps(Form1.Canvas.Handle,
                        LOGPIXELSY), 72), 0, 0, 0, FW_DONTCARE, 0, 1, 0,
                        DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS,
                        CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH or
                        FF_DECORATIVE, '');

  {select the font into the form's device context}
  OldFont := SelectObject(Form1.Canvas.Handle, NewFont);

  {output a line of text}
  TextOut(Form1.Canvas.Handle, 8, Label3.Top+Label3.Height, 'Delphi Rocks!',
          Length('Delphi Rocks!'));

  {select the old font back into the device context and delete the new font}
  SelectObject(Form1.Canvas.Handle, OldFont);
  DeleteObject(NewFont);

  {create an italicized font}
  NewFont := CreateFont(-MulDiv(16, GetDeviceCaps(Form1.Canvas.Handle,
                        LOGPIXELSY), 72), 0, 0, 0, FW_DONTCARE, 1, 0, 0,
                        DEFAULT_CHARSET, OUT_TT_ONLY_PRECIS,
                        CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH or
                        FF_SCRIPT, '');

  {select the font into the form's device context}
  OldFont := SelectObject(Form1.Canvas.Handle, NewFont);

  {output a line of text}
  TextOut(Form1.Canvas.Handle, 8, Label4.Top+Label4.Height, 'Delphi Rocks!',
          Length('Delphi Rocks!'));

  {select the old font back into the device context and delete the new font}
  SelectObject(Form1.Canvas.Handle, OldFont);
  DeleteObject(NewFont);
end;

end.