Font erstellen Laden mit Open GL , aber wie ?

[turboPASCAL]

Delphi-Quellcode:

{******************************************************************************}
{    FontGen Unit  - Create a Font from any Windowsfont                        }
{               __                                                             }
{   ...by      / /_____                                                        }
{            / __/ __ \                                                        }
{           / /_/ /_/ /                                                        }
{          \__/  ___/                                                          }
{            /_/                                                               }
{                                                                              }
{*********************************[ 14.07.2006 ]*******************************}

///// Sample: //////////////////////////////////////////////////////////////////
//
//  var
//    AnyFontMap: TFontMap; // Base Display List For The Font Set
//
//  BEGIN
//    BuildFont(DC, 'Arial', AnyFontMap, -14, [fsBold]);
//    ...
//    glGoto2D;
//    glPrintXY(10, 20, 'Sample', AnyFontMap);
//    glExit2D;
//    ...
//    glPrint3D(10,-10,10, 'Hallo', AnyFontMap);
//    ...
//    KillFont(AnyFontMap);
//  END.
//

unit FontGen;

interface

uses
  Windows, OpenGL;

  const
    GenListsCount = 256;

  type
    TFontMap = Record
                 Map: GLuint;
                 CharWidth: array [0..GenListsCount-1] of Integer;
                 CharHight: Integer;
               end;

    TGLFontStyle = (fsBold, fsItalic, fsUnderline, fsStrikeOut);
    TGLFontStyles = set of TGLFontStyle;

  procedure glCreateFont(DC: HDC; const FontName: string; var FontMap: TFontMap;
    const Size: Integer = 8; FontStyle: TGLFontStyles = []);
  procedure glKillFont(FontMap: TFontMap);
  procedure glPrint3D(X,Y, Z: Single; Text: String; FontMap: TFontMap);
  procedure glPrintXY(X,Y: Single; Text: String; FontMap: TFontMap); overload;
  procedure glPrintXY(X,Y: Single; Text: PChar; FontMap: TFontMap); overload;
  procedure glPrint(text: PChar; FontMap: TFontMap);
  function glGetTextLength(Text: String; FontMap: TFontMap): integer;

implementation

function TextExtent(DC: HDC; X: Char): TSize;
begin
  GetTextExtentPoint(DC, @X, 1, Result);
end;

procedure glCreateFont(DC: HDC; const FontName: string; var FontMap: TFontMap;
    const Size: Integer = 8; FontStyle: TGLFontStyles = []);
var
  font, oldfont: HFONT; 
  nBold, n: Integer;

  function isTrue(Value: TGLFontStyle): Byte;
  begin
    if Value in FontStyle then Result := 1 else Result := 0;
  end;

begin
  if fsBold in FontStyle then nBold := FW_BOLD else nBold := FW_NORMAL;

  FontMap.Map := glGenLists(GenListsCount);         // Storage For X Characters
  font := CreateFont(-MulDiv(Size, GetDeviceCaps(DC, LOGPIXELSY), 72), // Height Of Font
           0,                          // Width Of Font
           0,              // Angle Of Escapement
           0,              // Orientation Angle
           nBold,                // Font Weight
           isTrue(fsItalic),            // Italic
           isTrue(fsUnderline),         // Underline
           isTrue(fsStrikeOut),         // Strikeout
           ANSI_CHARSET,        // Character Set Identifier
           OUT_TT_PRECIS,             // Output Precision
           CLIP_DEFAULT_PRECIS,     // Clipping Precision
           ANTIALIASED_QUALITY,         // Output Quality
           FF_DONTCARE or DEFAULT_PITCH,// Family And Pitch
           PChar(FontName));        // Font Name

  oldfont := SelectObject(DC, font);        // Selects The previous font
  wglUseFontBitmaps(DC, 0, GenListsCount-1, FontMap.Map); // Builds X Characters Starting At Character 32

  for n := 0 to GenListsCount-1 do
    FontMap.CharWidth[n] := TextExtent(DC, Chr(n)).cx;
  FontMap.CharHight := TextExtent(DC, 'X').cy;

  SelectObject(DC, oldfont);                    // Put back the old font
  DeleteObject(font);                             // Delete the font we just created
end;                                              //   (we already have it in the Display list)

procedure glKillFont(FontMap: TFontMap);     // Delete The Font
begin
  glDeleteLists(FontMap.Map, GenListsCount);      // Delete the X Characters
end;

procedure glPrint3D(X, Y, Z: Single; Text: String; FontMap: TFontMap);
begin
  glPushMatrix;
  glDisable(GL_LIGHTING);
  glDisable(GL_TEXTURE_2D);
  glRasterPos3d(X, Y, Z);
  glPrint(PChar(Text), FontMap);
  glEnable(GL_TEXTURE_2D);
  glEnable(GL_LIGHTING);
  glPopMatrix;
end;

procedure glPrintXY(X,Y: Single; Text: String; FontMap: TFontMap); overload;
begin
  glRasterPos2f(X, Y);                            //This function is to position the text!!!
  glPrint(PChar(Text), FontMap);
end;

procedure glPrintXY(X,Y: Single; Text: PChar; FontMap: TFontMap); overload;
begin
  glRasterPos2f(X, Y);                            //This function is to position the text!!!
  glPrint(Text, FontMap);
end;

procedure glPrint(text : pchar; FontMap: TFontMap); // Custom GL "Print" Routine
begin
  if (text = '') then              // If There's No Text
    Exit;                 // just exit

  glPushAttrib(GL_LIST_BIT);           // Pushes The Display List Bits
  glListBase(FontMap.Map);           // Sets The Base Character

  glCallLists(length(text), GL_UNSIGNED_BYTE, text);  // Draws The Display List Text
  glPopAttrib();              // Pops The Display List Bits
end;

function glGetTextLength(Text: String; FontMap: TFontMap): integer;
var i, w: Integer;
begin
  w := 0;
  for i := 1 to length(Text) do
    w := w + FontMap.CharWidth[ord(Text[i])];
  Result := w;
end;

end.

Auch eine Möglichkeit.