unit Unit1;
interface
{$DEFINE DGLOGL}
uses
Winapi.Windows,
Winapi.Messages, System.SysUtils, System.Variants, System.Classes, System.UITypes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs,
Vcl.ExtCtrls,
{$IFDEF DGLOGL}
dglOpenGL
{$ELSE}
Winapi.OpenGL,
Winapi.OpenGLext
{$ENDIF};
type
TOpenGLContext =
class
public
Control: TControl;
DevCon: HDC;
RenderCon: HGLRC;
class procedure SetViewport(ClientWidth, ClientHeight: Integer);
procedure MakeCurrent;
end;
TglPanel =
class(TPanel)
public
OnPaint: TNotifyEvent;
procedure CreateRenderContext(oglc: TOpenGLContext);
//var DeviceContext: HDC; var RenderingContext: HGLRC);
protected
procedure WMEraseBkgnd(
var msg: TWmEraseBkgnd);
message WM_ERASEBKGND;
procedure WMPaint(
var msg: TWMPaint);
message WM_PAINT;
end;
TForm1 =
class(TForm)
procedure FormCreate(Sender: TObject);
private
procedure DreieckMalen(Sender: TObject);
public
glPanel: TglPanel;
procedure IdleHandler(Sender: TObject;
var Done: Boolean);
// GL zeichnen
end;
var
Form1: TForm1;
OpenGLContextMain: TOpenGLContext;
{$IFNDEF DGLOGL}
type
TRCOptions =
set of (opDoubleBuffered, opGDI, opStereo);
function CreateRenderingContext(
DC: HDC; Options: TRCOptions; ColorBits, ZBits, StencilBits, AccumBits, AuxBuffers: Integer; Layer: Integer): HGLRC;
{$ENDIF}
implementation
{$R *.dfm}
{$IFNDEF DGLOGL}
function CreateRenderingContext(
DC: HDC; Options: TRCOptions; ColorBits, ZBits, StencilBits, AccumBits, AuxBuffers: Integer; Layer: Integer): HGLRC;
const
MemoryDCs = [OBJ_MEMDC, OBJ_METADC, OBJ_ENHMETADC];
var
pfd: TPixelFormatDescriptor;
PixelFormat: Integer;
AType: DWORD;
begin
System.FillChar(pfd, SizeOf(pfd), 0);
pfd.nSize := SizeOf(pfd);
pfd.nVersion := 1;
pfd.dwFlags := PFD_SUPPORT_OPENGL;
AType := GetObjectType(
DC);
if (AType = 0)
then
RaiseLastOSError;
if (AType
in MemoryDCs)
then
pfd.dwFlags := pfd.dwFlags
or PFD_DRAW_TO_BITMAP
else
pfd.dwFlags := pfd.dwFlags
or PFD_DRAW_TO_WINDOW;
if opDoubleBuffered
in Options
then pfd.dwFlags := pfd.dwFlags
or PFD_DOUBLEBUFFER;
if opGDI
in Options
then pfd.dwFlags := pfd.dwFlags
or PFD_SUPPORT_GDI;
if opStereo
in Options
then pfd.dwFlags := pfd.dwFlags
or PFD_STEREO;
pfd.iPixelType := PFD_TYPE_RGBA;
pfd.cColorBits := ColorBits;
pfd.cDepthBits := zBits;
pfd.cStencilBits := StencilBits;
pfd.cAccumBits := AccumBits;
pfd.cAuxBuffers := AuxBuffers;
if (Layer = 0)
then
pfd.iLayerType := PFD_MAIN_PLANE
else
if (Layer > 0)
then
pfd.iLayerType := PFD_OVERLAY_PLANE
else
pfd.iLayerType := Byte(PFD_UNDERLAY_PLANE);
PixelFormat := ChoosePixelFormat(
DC, @pfd);
if PixelFormat = 0
then
RaiseLastOSError;
if GetPixelFormat(
DC) <> PixelFormat
then
if not SetPixelFormat(
DC, PixelFormat, @pfd)
then
RaiseLastOSError;
DescribePixelFormat(
DC, PixelFormat, SizeOf(pfd), pfd);
Result := wglCreateContext(
DC);
if Result = 0
then
RaiseLastOSError;
end;
{$ENDIF}
{ TglPanel }
procedure TglPanel.WMEraseBkgnd(
var msg: TWMEraseBkgnd);
begin
msg.Result := 1;
end;
procedure TglPanel.WMPaint(
var msg: TWMPaint);
var
PS: TPaintStruct;
begin
BeginPaint(
Handle, PS);
if Assigned(OnPaint)
then
OnPaint(Self);
EndPaint(
Handle, PS);
msg.Result := 0;
end;
procedure TglPanel.CreateRenderContext(oglc: TOpenGLContext);
//var DeviceContext: HDC; var RenderingContext: HGLRC);
begin
try
oglc.DevCon := GetDC(Self.Handle);
oglc.RenderCon := CreateRenderingContext(oglc.DevCon, [opDoubleBuffered], 32, 24, 8, 0, 0, 0);
wglMakeCurrent(oglc.DevCon, oglc.RenderCon);
{$IFNDEF DGLOGL}
Winapi.OpenGLExt.InitOpenGLext;
// Darf erst hier, nach wglMakeCurrent(), aufgerufen werden... Für z.B. MultiTexturing erforderlich...
{$ELSE}
ActivateRenderingContext(oglc.DevCon, oglc.RenderCon);
{$ENDIF}
glEnable(GL_DEPTH_TEST);
glDepthFunc(GL_LESS);
glEnable(GL_TEXTURE_2D);
except
MessageDlg('
Can''
t create OpenGL Rendering Context!', mtError, [mbOK], 0);
end;
end;
class procedure TOpenGLContext.SetViewport(ClientWidth, ClientHeight: Integer);
begin
glViewport(0, 0, ClientWidth, ClientHeight);
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
glOrtho(-ClientWidth / 2, ClientWidth / 2,
-ClientHeight / 2, ClientHeight / 2,
0, 100);
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
end;
procedure TOpenGLContext.MakeCurrent;
begin
wglMakeCurrent(DevCon, RenderCon);
// Ist das hier Schuld am Hänger? Könnte sein, testen!
TOpenGLContext.SetViewport(Control.Width, Control.Height);
glDisable(GL_BLEND);
glClearColor(0, 0, 0, 0);
glClear(GL_COLOR_BUFFER_BIT
or GL_DEPTH_BUFFER_BIT);
// or GL_STENCIL_BUFFER_BIT);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
OpenGLContextMain := TOpenGLContext.Create;
glPanel := TglPanel.Create(Self);
glPanel.Parent := Self;
glPanel.
Name := '
glPanel';
glPanel.Color := clBlack;
glPanel.ParentColor := FALSE;
glPanel.ParentBackground := FALSE;
glPanel.Align := alClient;
glPanel.CreateRenderContext(OpenGLContextMain);
glPanel.OnPaint := DreieckMalen;
OpenGLContextMain.Control := glPanel;
Application.OnIdle := IdleHandler;
end;
procedure TForm1.IdleHandler(Sender: TObject;
var Done: Boolean);
begin
glPanel.Invalidate;
// fglPanel.onPaint = DreieckMalen zeichnet für uns...
Form1.Caption := TimeToStr(Now);
// Uhrzeit als WindowTitle läuft weiter
Done := FALSE;
end;
procedure TForm1.DreieckMalen(Sender: TObject);
var
i: Cardinal;
x:
Array [0..2]
of Double;
y:
Array [0..2]
of Double;
begin
OpenGLContextMain.MakeCurrent;
// Drei Punkte rumwirbeln
for i := 0
to 2
do
begin
x[i] := 400 * sin((GetTickCount+(i*1000)) / 500);
y[i] := 300 * cos((GetTickCount+(i*1000)) / 700);
end;
// und Dreieck füllen
glDisable(GL_TEXTURE_2D);
glBegin(GL_TRIANGLES);
glColor4f(1.0, 0.0, 0.0, 1.0);
glVertex2f(x[0], y[0]);
glColor4f(0.0, 1.0, 0.0, 1.0);
glVertex2f(x[1], y[1]);
glColor4f(0.0, 0.0, 1.0, 1.0);
glVertex2f(x[2], y[2]);
glEnd();
SwapBuffers(OpenGLContextMain.DevCon);
end;
end.