unit1.pas

windows TTF 字型的delphi reader

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Buttons, ExtCtrls, ComCtrls, 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;
    TTF2Vector: TTTFToVectorConverter;
    FontDialog: TFontDialog;
    ColorDialog: TColorDialog;
    Timer: TTimer;
    UNICODEBtn: TSpeedButton;
    UseRgnBtn: 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);
    procedure UNICODEBtnClick(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: ^UINT;
    rgn: HRGN;
begin
  // Setup font
  TTF2Vector.Font := FontDialog.Font;
  // Setup spline precision (1 min, 100 max)
  TTF2Vector.Precision := PrecisionBar.Position;
  // Draw!
  if FillBtn.Down then // Filled
  begin
    // 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);
    // Allocate memory for the (all) points
    polys := AllocMem( sizeof(TPoint) * glyphs.Count );
    // Allocate memory for the "points per polygon" counters
    polyCounts := AllocMem( sizeof(UINT) * 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 );
      sog := glyphs.StartOfGlyph( i );
      for j := 0 to ppc^-1 do
      begin
        // Get a stroke
        stroke := glyphs.Stroke[sog+j];
        // 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 Win32 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 );
    // Free the glyphs
    glyphs.Free;
    // Release buffers
    FreeMem( polys );
    FreeMem( polyCounts );
  end
  else if UseRgnBtn.Down then // GDI region
  begin
    rgn := TTF2Vector.GetCharacterRegion( ord(FChar), PaintBox.Width-20, PaintBox.Height-20, 10, 10 );
    rgn := SelectObject( PaintBox.Canvas.Handle, rgn );
    PaintBox.Canvas.Pen.Width := 0;
    PaintBox.Canvas.Brush.Color := ColorDialog.Color;
    {$DEFINE XXX}
    {$IFDEF XXX}
    for i := 0 to PaintBox.Width-1 do
    begin
      PaintBox.Canvas.Pen.Color := round(i/(PaintBox.Width+1)* 256 + $001F00 );
      PaintBox.Canvas.MoveTo( i, 0 );
      PaintBox.Canvas.LineTo( i, PaintBox.Height-1 );
    end;
    {$ELSE}
    PaintBox.Canvas.FillRect( Rect( 0, 0, PaintBox.Width, PaintBox.Height ) );
    {$ENDIF}
    rgn := SelectObject( PaintBox.Canvas.Handle, rgn );
    DeleteObject( rgn );
  end
  else // Simplex
  begin
    // 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);
    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;
    // Free the glyphs
    glyphs.Free;
  end;
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;

procedure TMainForm.UNICODEBtnClick(Sender: TObject);
begin
  TTF2Vector.UNICODE := UNICODEBtn.Down;
  PaintBox.Invalidate;
end;

end.