unit1.pas

windows TTF 字型的delphi reader

unit Unit1;

interface

uses
  WinProcs, WinTypes, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, ExtCtrls, StdCtrls,

  {!} UTTF2Vct {!};

type
  TMainForm = class(TForm)
    Panel1: TPanel;
    FontBtn: TSpeedButton;
    Panel2: TPanel;
    ColorBtn: TSpeedButton;
    PrevCharBtn: TSpeedButton;
    TheChar: TSpeedButton;
    NextCharBtn: TSpeedButton;
    AutoBtn: TSpeedButton;
    QuitBtn: TSpeedButton;
    PaintBox: TPaintBox;
    Label1: TLabel;
    PrecisionBar: TScrollBar;
    PrecisionValue: TLabel;
    FillBtn: TSpeedButton;
    SpinBtn: TSpeedButton;
    FontDialog: TFontDialog;
    ColorDialog: TColorDialog;
    Timer: TTimer;
    TTF2Vector: TTTFToVectorConverter;
    UNICODEBtn: TSpeedButton;
    procedure FontBtnClick(Sender: TObject);
    procedure ColorBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure PrevCharBtnClick(Sender: TObject);
    procedure NextCharBtnClick(Sender: TObject);
    procedure AutoBtnClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure PaintBoxPaint(Sender: TObject);
    procedure TheCharClick(Sender: TObject);
    procedure QuitBtnClick(Sender: TObject);
    procedure PrecisionBarChange(Sender: TObject);
    procedure FillBtnClick(Sender: TObject);
    procedure SpinBtnClick(Sender: TObject);
  private
    FChar: char;
    FAngle: double;
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.DFM}

procedure TMainForm.FormCreate(Sender: TObject);
begin
  FChar := 'A';
  TheChar.Caption := FChar;
end;

procedure TMainForm.FontBtnClick(Sender: TObject);
begin
  try
    if FontDialog.Execute then
    begin
      FontDialog.Font.Size := 28;
      TheChar.Font := FontDialog.Font;
      PaintBox.Invalidate;
    end;
  except
  end;
end;

procedure TMainForm.ColorBtnClick(Sender: TObject);
begin
  try
    if ColorDialog.Execute then
      PaintBox.Invalidate;
  except
  end;
end;

procedure TMainForm.PrevCharBtnClick(Sender: TObject);
begin
  if FChar = #32 then
    FChar := #255
  else
    FChar := pred( FChar );
  TheChar.Caption := FChar;
  PaintBox.Invalidate;
end;

procedure TMainForm.NextCharBtnClick(Sender: TObject);
begin
  if FChar = #255 then
    FChar := #32
  else
    FChar := succ( FChar );
  TheChar.Caption := FChar;
  PaintBox.Invalidate;
end;

procedure TMainForm.AutoBtnClick(Sender: TObject);
begin
  Timer.Enabled := AutoBtn.Down or SpinBtn.Down;
end;

procedure TMainForm.TimerTimer(Sender: TObject);
begin
  FAngle := FAngle + 0.2;
  if FAngle > 2*pi then
    FAngle := FAngle - 2*pi;
  if AutoBtn.Down then
    NextCharBtnClick( nil )
  else
    PaintBox.Invalidate;
end;

procedure TMainForm.PaintBoxPaint(Sender: TObject);
var glyphs: TStrokeCollection;
    cbounds: TRect;
    sx, sy: double; { Scaling factors }
    stroke: TFontStroke;
    x1, y1,
    x2, y2, xm, ym: integer;
    i, j, k, sog: integer;
    polys, pps: ^TPoint;
    polyCounts, ppc: ^word;
begin
  { Setup font }
  TTF2Vector.Font := FontDialog.Font;
  { Setup spline precision (1 min, 100 max) }
  TTF2Vector.Precision := PrecisionBar.Position;
  { Get glyphs' strokes }
  glyphs := TTF2Vector.GetCharacterGlyphs( ord(FChar) );
  if glyphs = nil then { May be a "empty" glyph !!!! }
    exit;
  { Get character bounds }
  cbounds := glyphs.Bounds;
  xm := (cbounds.Right-cbounds.Left+1) div 2;
  ym := (cbounds.Bottom-cbounds.Top+1) div 2;
  { Compute the scaling factors }
  sx := (PaintBox.Width-20)/(cbounds.Right-cbounds.Left+1);
  sy := (PaintBox.Height-20)/(cbounds.Bottom-cbounds.Top+1);
  { Draw! }
  if not FillBtn.Down then { Simplex }
  begin
    PaintBox.Canvas.Pen.Color := ColorDialog.Color;
    for i := 0 to glyphs.Count-1 do
    begin
      { Get a stroke }
      stroke := glyphs.Stroke[i];
      { Scale it down or up / Rotate }
      if not SpinBtn.Down then
      begin
        x1 := 10 + round( (stroke.Pt1.X-cbounds.Left) * sx );
        x2 := 10 + round( (stroke.Pt2.X-cbounds.Left) * sx );
        y1 := 10 + round( (stroke.Pt1.Y-cbounds.Top) * sy );
        y2 := 10 + round( (stroke.Pt2.Y-cbounds.Top) * sy );
      end
      else
      begin
        x1 := 10 + round( ( (stroke.Pt1.X-cbounds.Left-xm) * sin( FAngle ) + xm ) * sx );
        x2 := 10 + round( ( (stroke.Pt2.X-cbounds.Left-xm) * sin( FAngle ) + xm ) *sx );
        y1 := 10 + round( ( (stroke.Pt1.Y-cbounds.Top-ym) * cos(FAngle) + ym ) * sy );
        y2 := 10 + round( ( (stroke.Pt2.Y-cbounds.Top-ym) * cos(FAngle) + ym ) * sy );
      end;
      { Draw the stroke }
      PaintBox.Canvas.MoveTo( x1, PaintBox.Height-y1-1 );
      PaintBox.Canvas.LineTo( x2, PaintBox.Height-y2-1 );
    end;
  end
  else { Filled }
  begin
    { Allocate memory for the (all) points }
    { Note: unlike Win95, Win31 doesn't close poligons automatically ! }
    polys := AllocMem( sizeof(TPoint) * ( glyphs.Count + glyphs.NumGlyphs ) );
    { Allocate memory for the "points per polygon" counters }
    polyCounts := AllocMem( sizeof(word) * glyphs.NumGlyphs );
    { Copy glyphs' points to the allocated buffers }
    pps := polys;
    ppc := polyCounts;
    for i := 0 to glyphs.NumGlyphs-1 do
    begin
      ppc^ := glyphs.GlyphNumStrokes( i )+1;
      sog := glyphs.StartOfGlyph( i );
      for j := 0 to ppc^-1 do
      begin
        { Get a stroke }
        if j < ppc^-1 then
          stroke := glyphs.Stroke[sog+j]
        else
          stroke := glyphs.Stroke[sog];
        { Scale/Rotate & store }
        if not SpinBtn.Down then
        begin
          pps^.x := 10 + round( (stroke.Pt1.X-cbounds.Left) * sx );
          pps^.y := PaintBox.Height - (10 + round( (stroke.Pt1.Y-cbounds.Top) * sy ))-1;
        end
        else
        begin
          pps^.x := 10 + round( ( (stroke.Pt1.X-cbounds.Left-xm) * cos( FAngle ) + xm ) * sx );
          pps^.y := PaintBox.Height - (10 + round( ( (stroke.Pt1.Y-cbounds.Top-ym) * sin(FAngle) + ym ) * sy ))-1;
        end;
        pps := pointer( pchar(pps) + sizeof(TPoint) );
      end;
      ppc := pointer( pchar(ppc) + sizeof(ppc^) );
    end;
    { Draw the character using PolyPolygon (see Win31 API Help) }
    PaintBox.Canvas.Pen.Color := ColorDialog.Color;
    PaintBox.Canvas.Pen.Width := 0;
    PaintBox.Canvas.Brush.Color := ColorDialog.Color;
    if not SpinBtn.Down or (FAngle<pi/2) or (FAngle>3/2*pi) then
      PaintBox.Canvas.Brush.Style := bsSolid
    else
      PaintBox.Canvas.Brush.Style := bsFDiagonal;
    SetPolyFillMode( PaintBox.Canvas.Handle, WINDING );
    PolyPolygon( PaintBox.Canvas.Handle,
                 polys^,
                 polyCounts^,
                 glyphs.NumGlyphs );
    { Release buffers }
    FreeMem( polys, sizeof(TPoint) * glyphs.Count );
    FreeMem( polyCounts, sizeof(word) * glyphs.NumGlyphs );
  end;
  { Free the glyphs }
  glyphs.Free;
end;

procedure TMainForm.TheCharClick(Sender: TObject);
begin
  FChar := 'A';
  PaintBox.Invalidate;
end;

procedure TMainForm.QuitBtnClick(Sender: TObject);
begin
  Close;
end;

procedure TMainForm.PrecisionBarChange(Sender: TObject);
begin
  PrecisionValue.Caption := IntToStr( PrecisionBar.Position );
  PaintBox.Invalidate;
end;

procedure TMainForm.FillBtnClick(Sender: TObject);
begin
  PaintBox.Invalidate;
end;

procedure TMainForm.SpinBtnClick(Sender: TObject);
begin
  FAngle := 0.0;
  if SpinBtn.Down then
  begin
    Timer.Interval := 70;
    Timer.Enabled := true;
  end
  else
  begin
    Timer.Interval := 300;
    Timer.Enabled := AutoBtn.Down;
  end;
  PaintBox.Invalidate;
end;

end.