[转帖]OpenGL实现中文显示——改进版

鼯鼠

上次我发了个帖子，名为《OpenGL实现中文显示》。有朋友说使用 wglUseFontBitMapsW 函数就可以显示中文，由于考虑兼容问题，所以没有在原文给出实现方法。后来觉得使用 Window9X/Me 的人越来越少，所以决定改进一下原来的代码，以便支持 Unicode 编码。修改后的代码如下：

unit Unit2;

interface

uses
Windows, Messages, SysUtils, Variants, Graphics, GL, GLu, GLext;

Type
PGLFont = ^TGLFont;
TGLFont = record
b3D : Boolean; //三维字体？
bBold : Boolean; //粗体？
bItalic : Boolean; //斜体？
Height : Integer;
Weight : Integer;
CharSet : Cardinal; //字符集
Typeface: PChar; //字体
end;
TGLText = class
private
bUniCode : Boolean; //OS支持Unicode吗?
GLStrEng : PChar; //英文字串
GLStrChn : PChar; //中文字串

procedure Build(srcDC: HDC; glStr: PChar; glFont: PGLFont);
procedure GetWinVer;
procedure wglUseFontBitmapsExt(srcDC : HDC; First, Count, ListBase : DWORD);
public
constructor Create(srcDC : HDC; EngStr, ChnStr : PChar;
EngFont, ChnFont : PGLFont);
destructor Destroy; override;
procedure glShowStr(glStr : PChar);
end;

implementation

{ TGLText }
procedure TGLText.Build(srcDC: HDC; glStr: PChar; glFont: PGLFont);
var
i,
Chartmp : Byte;
CharW : PWideChar;

Font, oFont : HFONT;
glBold : Integer;
glItalic : Cardinal;
dwChar : DWORD;
gmf : GLYPHMETRICSFLOAT;
begin

if glFont.bBold then
glBold := FW_BOLD
else
glBold := FW_NORMAL;

if glFont.bItalic then
glItalic := 1
else
glItalic := 0;

Font := CreateFont(glFont.Height, glFont.Weight, 0, 0, glBold, glItalic,
0, 0, glFont.CharSet, OUT_TT_PRECIS,
CLIP_DEFAULT_PRECIS, ANTIALIASED_QUALITY,
FF_DONTCARE or DEFAULT_PITCH,
glFont.Typeface);

oFont := SelectObject(srcDC, Font);

if glStr = 'All English' then
begin
if bUniCode then
if glFont.b3D then
wglUseFontOutLinesW(srcDC, 32, 125, 32, 0, 0, WGL_FONT_POLYGONS, @gmf)
else
wglUseFontBitMapsW(srcDC, 32, 125, 32)
else
if glFont.b3D then
wglUseFontOutLines(srcDC, 32, 125, 32, 0, 0, WGL_FONT_POLYGONS, @gmf)
else
wglUseFontBitMaps(srcDC, 32, 125, 32);
end
else
begin
i := 0;
While i < Length(glStr) do
begin
if bUniCode then
begin
GetMem(CharW, (Length(glStr) + 1) * 2);
StringToWideChar(glStr, CharW, Length(glStr) + 1);
dwChar := Word(CharW);
if glFont.b3D then
wglUseFontOutLinesW(srcDC, dwChar, 1, dwChar, 0, 0,
WGL_FONT_POLYGONS, @gmf)
else
wglUseFontBitMapsW(srcDC, dwChar, 1, dwChar);
FreeMem(CharW, (Length(glStr) + 1) * 2);
i := i + 1;
end
else
begin
Chartmp := Byte(glStr);
if glStr in LeadBytes then
begin
dwChar := ((Chartmp shl 8) or Byte(glStr[i+1]));
i := i + 2;
end
else
begin
dwChar := Chartmp;
i := i + 1;
end;
if glFont.b3D then
wglUseFontOutLines(srcDC, dwChar, 1, dwChar, 0, 0,
WGL_FONT_POLYGONS, @gmf)
else
wglUseFontBitMapsExt(srcDC, dwChar, 1, dwChar);
end;
end;
end;

SelectObject(srcDC, oFont);
DeleteObject(Font);

end;

constructor TGLText.Create(srcDC : HDC; EngStr, ChnStr: PChar;
EngFont, ChnFont: PGLFont);
begin
GetWinVer;

GLStrEng := EngStr;
GLStrChn := ChnStr;

if EngStr <> nil then
Build(srcDC, EngStr, EngFont);

if ChnStr <> nil then
Build(srcDC, ChnStr, ChnFont);

end;

destructor TGLText.Destroy;
var
i,
Chartmp : Byte;
CharW : PWideChar;
dwChar : DWORD;
begin

if GLStrEng <> nil then
if GLStrEng = 'All English' then
begin
glDeleteLists(32, 93);
end
else
begin
i := 0;
While i < Length(GLStrEng) do
begin
dwChar := Byte(GLStrEng);
glDeleteLists(dwChar, 1);
i := i + 1;
end;
end;

if GLStrChn <> nil then
begin
i := 0;
While i < Length(GLStrChn) do
begin
if bUniCode then
begin
GetMem(CharW, (Length(GLStrChn) + 1) * 2);
StringToWideChar(GLStrChn, CharW, Length(GLStrChn) + 1);
dwChar := Word(CharW);
glDeleteLists(dwChar, 1);
FreeMem(CharW, (Length(GLStrChn) + 1) * 2);
i := i + 1;
end
else
begin
Chartmp := Byte(GLStrChn);
if GLStrChn in LeadBytes then
begin
dwChar := ((Chartmp shl 8) or Byte(GLStrChn[i+1]));
i := i + 2;
end
else
begin
dwChar := Chartmp;
i := i + 1;
end;
glDeleteLists(dwChar, 1);
end;
end;
end;

inherited Destroy;

end;

procedure TGLText.GetWinVer;
var
VersionInfo: TOSVersionInfo;
begin
VersionInfo.dwOSVersionInfoSize := SizeOf(VersionInfo);
GetVersionEx(VersionInfo);
if Versioninfo.dwPlatformId < 2 then
bUniCode := False
else
bUniCode := True;
end;

procedure TGLText.glShowStr(glStr : PChar);
var
i,
Chartmp : Byte;
CharW : PWideChar;
dwChar : DWORD;
begin

i := 0;
While i < Length(glStr) do
begin
if bUniCode then
begin
GetMem(CharW, (Length(glStr) + 1) * 2);
StringToWideChar(glStr, CharW, Length(glStr) + 1);
dwChar := Word(CharW);
FreeMem(CharW, (Length(glStr) + 1) * 2);
i := i + 1;

glCallList(dwChar);
end
else
begin
Chartmp := Byte(glStr);
if glStr in LeadBytes then
begin
dwChar := ((Chartmp shl 8) or Byte(glStr[i+1]));
i := i + 2;
end
else
begin
dwChar := Chartmp;
i := i + 1;
end;
glCallList(dwChar);
end;
end;

end;

procedure TGLText.wglUseFontBitmapsExt(srcDC: HDC; First, Count,
ListBase: DWORD);
var
i : DWORD;
size : DWORD;
gm : GLYPHMETRICS;
hBits : THANDLE;
lpBits : PGLubyte;
mat : MAT2;
begin

mat.eM11.fract := 0;
mat.eM11.value := 1;
mat.eM12.fract := 0;
mat.eM12.value := 0;
mat.eM21.fract := 0;
mat.eM21.value := 0;
mat.eM22.fract := 0;
mat.eM22.value := -1;

for i := 0 to Count - 1 do
begin
glNewList(ListBase+i, GL_COMPILE);

size := GetGlyphOutline(srcDC, First+i, GGO_BITMAP, gm, 0, nil, mat);

hBits := GlobalAlloc(GHND, size);
lpBits := GlobalLock(hBits);

GetGlyphOutline(srcDC, //* handle to device context */
First+i, //* character to query */
GGO_BITMAP, //* format of data to return */
gm, //* pointer to structure for metrics */
size, //* size of buffer for data */
lpBits, //* pointer to buffer for data */
mat //* pointer to transformation */
//* matrix structure */
);

glBitmap(gm.gmBlackBoxX,gm.gmBlackBoxY,
gm.gmptGlyphOrigin.x,
gm.gmptGlyphOrigin.y,
gm.gmCellIncX,gm.gmCellIncY,
lpBits);

GlobalUnlock(hBits);
GlobalFree(hBits);

glEndList;
end;

end;

end.

这次我把使用的例子也贴上了：

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DotWindow, GL, GLu, GLext, Unit2;

type
TForm1 = class(TDotForm)
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormPaint(Sender: TObject);
procedure FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
fX, fY : Integer;
MyText : TGLText;

procedure BuildLists;
procedure Clearing;
procedure DrawInfo;
procedure InitGLStatus(width, height: GLsizei);
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
fX := 640;
fY := 480;
Self.BorderStyle := bsNone;
Self.Height := fY;
Self.Width := fX;
Self.Context.DC := GetDC(Self.Handle);
ShowCursor(False);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
Self.Context.QuickPF(32, 0, 24, 0);
Self.Context.InitGL;
InitGLStatus(Self.ClientWidth, Self.ClientHeight);
BuildLists;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
MyText.Free;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
clearing;
DrawInfo;
Self.Context.PageFlip;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_ESCAPE :
begin
Clearing;
Self.Close;
end;
end;
end;

procedure TForm1.Clearing;
begin
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
end;

procedure TForm1.InitGLStatus(width, height: GLsizei);
begin
glClearColor(0, 0, 0, 0.5);
glMatrixMode(GL_PROJECTION);
gluOrtho2D(-(fX div 2), fX div 2, -(fY div 2), fY div 2);
glMatrixMode(GL_MODELVIEW);
end;

procedure TForm1.BuildLists;
var
StrE, StrC : TGLFont;
begin
//中、英文字体
StrE.b3D := False;
StrE.bBold := False;
StrE.bItalic := False;
StrE.Height := 13;
StrE.Weight := 0;
StrE.CharSet:= ANSI_CHARSET;
StrE.Typeface := 'Tahoma';

StrC.b3D := False;
StrC.bBold := False;
StrC.bItalic := False;
StrC.Height := 13;
StrC.Weight := 0;
StrC.CharSet:= GB2312_CHARSET;
StrC.Typeface := 'Tahoma';

MyText := TGLText.Create(Self.Context.DC,
'All English' , '这是中文请按键退出。……',
@StrE, @StrC);
end;

procedure TForm1.DrawInfo;
begin
glLoadIdentity;
glRasterPos2f(-250, 200);
MyText.glShowStr('这是中文。');

glRasterPos2f(-250, 150);
MyText.glShowStr('These are English characters. ');

glRasterPos2f(-80, -80);
MyText.glShowStr('请按 Esc 键退出……');
end;

end.

我用 Delphi 6 以及 Delphi 2006(Delphi 10) 验证通过。
有疑问可以发帖，或者发邮件给我，地址如下：
testerHooK@126.com
演示程序请见附件（含源代码）。

P.S. 演示程序用到了DOT工具，请到www.delphi3d.net下载最新版。