Delphi OpenGL тест - PullRequest
       12

Delphi OpenGL тест

1 голос
/ 17 декабря 2009

Я читал книгу Delphi Developer's Guide to OpenGL, и этот код должен устанавливать цвет фона окна, но он не работает, может кто-нибудь сказать мне, что случилось ??

type
   TForm1 = class(TForm)
      procedure Form_Create(Sender: TObject);
    procedure Form_Destroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
      private
         glContext   : HGLRC;
         glDC        : HDC;
         errorCode   : GLenum;
         openGLReady : Boolean;
      public
   end;

var
   Form1 : TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormPaint(Sender: TObject);
begin
   if not openGLReady then
      exit;
   {background}
   glClearColor(0.1,0.4,0.0,0.0);
   glClear(GL_COLOR_BUFFER_BIT);
   {error checking}
   errorCode:=glGetError;
   if errorCode<>GL_NO_ERROR then
      raise Exception.Create('Error in Paint'#13+gluErrorString(errorCode));
end;

procedure TForm1.Form_Create(Sender: TObject);
var
   pfd : TPixelFormatDescriptor;
   FormatIndex: integer;
begin
   fillchar(pfd,SizeOf(pfd),0);
   with pfd do
   begin
      nSize := SizeOf(pfd);
      nVersion := 1; {The current version of the desccriptor is 1}
      dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
      iPixelType := PFD_TYPE_RGBA;
      cColorBits := 24; {support 24-bit color}
      cDepthBits := 32; {depth of z-axis}
      iLayerType := PFD_MAIN_PLANE;
   end; {with}
   glDC := getDC(handle);
   FormatIndex := ChoosePixelFormat(glDC,@pfd);
   if FormatIndex=0 then
      raise Exception.Create('ChoosePixelFormat failed '+IntToStr(GetLastError));
   if not SetPixelFormat(glDC,FormatIndex,@pfd) then
      raise Exception.Create('SetPixelFormat failed '+IntToStr(GetLastError));
   GLContext := wglCreateContext(glDC);
   if GLContext=0 then
      raise Exception.Create('wglCreateContext failed '+IntToStr(GetLastError));
   if not wglMakeCurrent(glDC,GLContext) then
      raise Exception.Create('wglMakeCurrent failed '+IntToStr(GetLastError));
   OpenGLReady := true;
end;

procedure TForm1.Form_Destroy(Sender: TObject);
begin
   wglMakeCurrent(Canvas.Handle, 0);
   wglDeleteContext(GLContext);
end;

Ответы [ 2 ]

3 голосов
/ 18 декабря 2009

Добавьте в конце процедуры команду FormPaint opengl:

glFlush();
0 голосов
/ 17 декабря 2009
swapbuffers(gldc);

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...