[angvelem]

Разобрался с XE2:

Код:

program lesson14a;

uses
  Windows, Messages, sysutils, OpenGL;

var
  h_Rc		: HGLRC;
  h_Dc		: HDC;
  h_Wnd		: HWND;
  keys		: array[0..255] of Boolean;
  Active	: Boolean = True;
  FullScreen	: Boolean = true;
  base		: GLuint;
  rot		: GLfloat = 0.01;
  gmf		: array[Byte] of GLYPHMETRICSFLOAT;
  Color		: Glfloat = 0.0;
  ColorShowDelay	: Glfloat = 0.0;
  ColorNightDelay	: Glfloat = 0.0;
  ColorInverse	: Boolean = False;
  ColorPause	: Boolean = False;
  ColorNight	: Boolean = False;

procedure BuildFont;
var
  Font: HFONT;
begin
  base := glGenLists(256);
  font := CreateFontA(-MulDiv(12, GetDeviceCaps(h_DC, LOGPIXELSY), 72),
                      0, 0, 0, FW_BOLD, 0, 0, 0,
                      ANSI_CHARSET or RUSSIAN_CHARSET,
                      OUT_TT_PRECIS,
                      CLIP_DEFAULT_PRECIS,
                      ANTIALIASED_QUALITY,
                      FF_DONTCARE or DEFAULT_PITCH,
                      'Courier New CYR');
  SelectObject(h_dc, font);
  wglUseFontOutlinesA(h_dc, 0, 255, base, 0, 0, WGL_FONT_POLYGONS, @gmf);
end;

procedure KillFont;
begin
  glDeleteLists(base, 256);
end;

procedure glPrint(Text : AnsiString);
var
  len  : glfloat;
  loop : integer;
begin
  if text = '' then
    Exit;
  len := 0;
  for loop := 1 to length(text) - 1 do
    len := len + gmf[loop].gmfCellIncX;
  glTranslatef(-len / 2, 0.0, 0.0);
  glPushAttrib(GL_LIST_BIT);
  glListBase(base);
  glCallLists(Length(text), GL_UNSIGNED_BYTE, PAnsiChar(Text));
  glPopAttrib;
end;

procedure ReSizeGLScene(Width: GLsizei; Height: GLsizei);
begin
  if Height = 0 then
    Height := 1;
  glViewport(0, 0, Width, Height);
  glMatrixMode(GL_PROJECTION);
  glLoadIdentity;
  gluPerspective(45.0, Width / Height, 0.1, 100.0);
  glMatrixMode(GL_MODELVIEW);
  glLoadIdentity;
end;


function InitGL : Boolean;
begin
  glShadeModel(GL_SMOOTH);
  glClearColor(0.0, 0.0, 0.0, 0.5);
  glClearDepth(1.0);
  glEnable(GL_DEPTH_TEST);
  glDepthFunc(GL_LEQUAL);
  glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST);
  glEnable(GL_LIGHT0);
  glEnable(GL_LIGHTING);
  glEnable(GL_COLOR_MATERIAL);
  BuildFont;
  Result := True;
end;

function DrawGLScene : Boolean;
begin
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  glLoadIdentity;
  glTranslatef(0, 0, -30);

  if ColorPause then
  begin
    ColorShowDelay := ColorShowDelay + rot;
    if ColorShowDelay >= 2.0 then
    begin
      ColorShowDelay := 0.0;
      ColorPause := False;
    end;
  end
  else if ColorNight then
  begin
    ColorNightDelay := ColorNightDelay + rot;
    if ColorNightDelay >= 5.0 then
    begin
      ColorNightDelay := 0.0;
      ColorNight := False;
    end;
  end
  else
  begin
    if not ColorInverse then
    begin
      Color := Color + rot;
      if Color >= 1.0 then
      begin
        ColorInverse := True;
        ColorPause := True;
      end;
    end
    else
    begin
      Color := Color - rot;
      if Color <= 0.0 then
      begin
        ColorInverse := False;
        ColorNight := True;
      end
    end;
  end;

  glColor3f(0.0, Color, Color);
  glPrint('Всё Круто');
  Result := True;
end;


function WndProc(Wnd : HWND; Msg, wParam, lParam : Longint) : Longint; stdcall;
begin
  Result := 0;
  
  case Msg of
    WM_SYSCOMMAND :
    begin
      case wParam of
        SC_SCREENSAVE,
        SC_MONITORPOWER : Exit;
      end;
    end;

    WM_ACTIVATE :
    begin
      if Hiword(wParam) = 0 then
        Active := True
      else
        Active := False;
      Exit;
    end;

    WM_CLOSE :
    begin
      PostQuitMessage(0);
      Exit;
    end;

    WM_KEYDOWN :
    begin
      keys[wParam] := True;
      Exit;
    end;

    WM_KEYUP :
    begin
      keys[wParam] := False;
      Exit;
    end;

    WM_SIZE :
    begin
      ReSizeGLScene(LOWORD(lParam), HIWORD(lParam));
      Exit;
    end;
  end;
  Result := DefWindowProc(Wnd, Msg, wParam, lParam);
end;

procedure KillGLWindow;
begin
  if FullScreen then
  begin
    ChangeDisplaySettings(devmode(NIL^), 0);
    ShowCursor(True);
  end;

  if h_rc <> 0 then
  begin
    if not wglMakeCurrent(h_Dc, 0) then
      MessageBox(0, 'Release of DC and RC failed.', ' Shutdown Error', MB_OK or MB_ICONERROR);

    if not wglDeleteContext(h_Rc) then
    begin
      MessageBox(0, 'Release of Rendering Context failed.', ' Shutdown Error', MB_OK or MB_ICONERROR);
      h_Rc := 0;
    end;
  end;

  if (h_Dc = 1) and (ReleaseDC(h_Wnd, h_Dc) <> 0) then
  begin
    MessageBox(0, 'Release of Device Context failed.', ' Shutdown Error', MB_OK or MB_ICONERROR);
    h_Dc := 0;
  end;

  if (h_Wnd <> 0) and (not DestroyWindow(h_Wnd)) then
  begin
    MessageBox(0, 'Could not release hWnd.', ' Shutdown Error', MB_OK or MB_ICONERROR);
    h_Wnd := 0;
  end;

  if not UnregisterClass('OpenGL', hInstance) then
    MessageBox(0, 'Could Not Unregister Class.', 'SHUTDOWN ERROR', MB_OK or MB_ICONINFORMATION);
  KillFont;
end;

function DoRegister : Boolean;
var
  WC : TWndClass;
begin
  wc.style		:= CS_HREDRAW or CS_VREDRAW or CS_OWNDC;
  wc.lpfnWndProc	:= @WndProc;
  wc.cbClsExtra		:= 0;
  wc.cbWndExtra		:= 0;
  wc.hInstance		:= hInstance;
  wc.hIcon		:= LoadIcon(0, IDI_WINLOGO);
  wc.hCursor		:= LoadCursor(0, IDC_ARROW);
  wc.hbrBackground	:= GetStockObject(BLACK_BRUSH);
  wc.lpszMenuName	:= '';
  wc.lpszClassName	:= 'OpenGl';

  Result := RegisterClass(wc) <> 0;
end;