glfont.pas

一个用Delphi编写的很好的屏保程序

unit glFont;
{(c) 1999 Production Robots Engineering Ltd (Martin Lafferty)
     [e-mail]
}

interface
uses
  SysUtils,
  Windows,
  Geometry,
  OpenGL12;

type
  TValidChar = #$20..#$7E;
  TglFontMetrics = array[TValidChar] of TGlyphMetricsFloat;

  TglFont = class
  private
    Metrics: TglFontMetrics;
    ListBase: Integer;
    FFontZ: Single;
    FFontY: Single;
    FFontScale: Double;
    function CharValid(c: Char): Boolean;
    function GetFontHeight: Single;
    procedure SetFontHeight(const Value: Single);
    function GetFontZ: Single;
  public
    constructor Create(const FaceName: String;
                             Italic: Boolean;
                             Bold: Boolean;
                             Outline: Boolean;
                             Extrusion: Single);
    procedure WriteStr(const S: String);
    procedure TextExtent(const S: String; var Size: TVector3f);
    property FontDepth: Single read GetFontZ;
    property FontHeight: Single read GetFontHeight write SetFontHeight;
  end;

implementation

const
  ValidCharCount = Ord(High(TValidChar)) - Ord(Low(TValidChar)) + 1;
  Deviation = 0.4;
  Eps20 = 1-20;

{ TglFont }

function TglFont.CharValid(c: Char): Boolean;
begin
  Result:= (c >= Low(TValidChar)) and
           (c <= High(TValidChar))
end;

constructor TglFont.Create(const FaceName: String;
                                 Italic: Boolean;
                                 Bold: Boolean;
                                 Outline: Boolean;
                                 Extrusion: Single);
var
  dc: hDC;
  PrevFont, Font: hFont;
  lf: TLogFont;
  i: Char;
  Format: Integer;
begin
  inherited Create;
  FFontScale:= 1;
  FFontZ:= Extrusion;
  dc:= wglGetCurrentDC;
  with lf do
  begin
    lfHeight:= 0;
    lfWidth:= 0;
    lfEscapement:= 0;
    lfOrientation:= 0;
    if Bold then
      lfWeight:= FW_BOLD
    else
      lfWeight:= FW_NORMAL;
    lfItalic:= Byte(Italic);
    lfUnderline:= 0;
    lfStrikeOut:= 0;
    lfCharSet:= DEFAULT_CHARSET;
    lfOutPrecision:= OUT_DEFAULT_PRECIS;
    lfClipPrecision:= CLIP_DEFAULT_PRECIS;
    lfQuality:= DEFAULT_QUALITY;
    lfPitchAndFamily:= FF_DONTCARE;
    StrLCopy(lfFaceName, PChar(FaceName), SizeOf(lfFaceName)-1);
  end;
  Font:= CreateFontIndirect(lf);
  PrevFont:= SelectObject(dc, Font);
  ListBase:= glGenLists(ValidCharCount);
  if Outline then
    Format:= WGL_FONT_LINES
  else
    Format:= WGL_FONT_POLYGONS;
  wglUseFontOutlines(dc, Ord(Low(TValidChar)), ValidCharCount,
    ListBase, Deviation, Extrusion, Format, @Metrics);
  SelectObject(dc, PrevFont);
  DeleteObject(Font);
  for i:= Low(TValidChar) to High(TValidChar) do
  begin
    if Metrics[i].gmfBlackBoxY > FFontY then
      FFontY:= Metrics[i].gmfBlackBoxY
  end
end;

function TglFont.GetFontHeight: Single;
begin
  Result:= FFontScale*FFontY
end;

function TglFont.GetFontZ: Single;
begin
  Result:= FFontZ * FFontScale
end;

procedure TglFont.SetFontHeight(const Value: Single);
begin
  if Abs(FFontY) > Eps20 then
    FFontScale:= Value/FFontY
  else
    FFontScale:= 1
end;

procedure TglFont.TextExtent(const S: String; var Size: TVector3f);
var
  i: Integer;
  c: Char;
begin
  Size[2]:= FontDepth;
  Size[0]:= 0;
  Size[1]:= 0;
  for i:= 1 to Length(S) do
  begin
    c:= S[i];
    if CharValid(c) then
    begin
      Size[0]:= Size[0] + Metrics[c].gmfCellIncX;
      if Metrics[c].gmfBlackBoxY > Size[1] then
        Size[1]:= Metrics[c].gmfBlackBoxY
    end
  end;
  Size[0]:= Size[0]*FFontScale;
  Size[1]:= Size[1]*FFontScale
end;

procedure TglFont.WriteStr(const S: String);
var
  WasNormal: Boolean;
begin
  glListBase(ListBase - Ord(Low(TValidChar)));
  if Abs(FFontScale - 1) > Eps20 then
  begin
    glPushMatrix;
    WasNormal:= glIsEnabled(GL_RESCALE_NORMAL) = 1;
    glEnable(GL_RESCALE_NORMAL);
    glScaled(FFontScale, FFontScale, FFontScale);
    glCallLists(Length(S), GL_BYTE, PChar(S));
    if not WasNormal then
      glDisable(GL_RESCALE_NORMAL);
    glPopMatrix
  end else
  begin
    glCallLists(Length(S), GL_BYTE, PChar(S))
  end
end;

end.