Delphi的OpenGL控件

控件源码如下:

unit OpenGLWinControl;

interface

uses System.SysUtils, System.Classes, Vcl.Controls, Winapi.Messages,
  Winapi.OpenGL, Winapi.Windows;

type
  TDebugEvent = procedure(Sender: TObject; Info: string; Level: integer)
    of object;

  TOpenGLWinControl = class(TWinControl)
  public
    HandleOfDeviceContex: HDC;
    HandleOfGLRenderContex: HGLRC;
  private
    fOnSetPixelFormatDescriptor: TNotifyEvent;
    fOnPaint: TNotifyEvent;
    fDebugEvent: TDebugEvent;
    { Private declarations }
    procedure WMCreate(var Message: TWMCreate); message WM_CREATE;
    procedure WMDestroy(var Message: TWMDestroy); message WM_DESTROY;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  protected
    { Protected declarations }
    procedure AppendLog(txt: string);
  published
    { Public declarations }
    property OnSetPixelFormatDescriptor: TNotifyEvent
      read fOnSetPixelFormatDescriptor write fOnSetPixelFormatDescriptor;
    property OnPaint: TNotifyEvent read fOnPaint write fOnPaint;
  public
    procedure Render();
  published
    { Published declarations }
    // 鼠标事件
    property OnMouseDown;
    property OnMouseUp;
    property OnMouseMove;
    property OnMouseWheelDown;
    property OnMouseWheelUp;
    // 大小变化产生的事件
    property OnResize;
    // 对齐
    property Align;
  published
    // 调试用的事件
    property OnDebugEvent: TDebugEvent read fDebugEvent write fDebugEvent;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('OpenGL', [TOpenGLWinControl]);
end;

{ TOpenGLWinControl }

procedure TOpenGLWinControl.AppendLog(txt: string);
begin
  if Assigned(self.fDebugEvent) then begin
    fDebugEvent(self, txt, 0);
  end;
end;

procedure TOpenGLWinControl.Render;
begin
  wglMakeCurrent(HandleOfDeviceContex, HandleOfGLRenderContex);
  if Assigned(fOnPaint) then begin
    fOnPaint(self);
  end;
end;

procedure TOpenGLWinControl.WMCreate(var Message: TWMCreate);
var next: boolean;
begin
  inherited;
  next := not(csDesigning in ComponentState);
  if next then begin
    HandleOfDeviceContex := GetDC(self.Handle);
    next := HandleOfDeviceContex <> 0;
  end;
  if next then begin
    next := Assigned(fOnSetPixelFormatDescriptor);
  end;
  if next then begin
    fOnSetPixelFormatDescriptor(self);
    HandleOfGLRenderContex := wglCreateContext(HandleOfDeviceContex);
    next := HandleOfGLRenderContex <> 0;
  end;
end;

procedure TOpenGLWinControl.WMDestroy(var Message: TWMDestroy);
begin
  inherited;
  if not(csDesigning in ComponentState) then begin
    wglMakeCurrent(0, 0);
    wglDeleteContext(HandleOfGLRenderContex);
  end;
end;

procedure TOpenGLWinControl.WMPaint(var Message: TWMPaint);
var PS: TPaintStruct; DC: HDC;
begin
  if (csDesigning in ComponentState) then begin
    inherited;
  end else begin
    // inherited;
    try
      DC := BeginPaint(Handle, PS);
      EndPaint(Handle, PS);
      self.Render;
      // DC := BeginPaint(Handle, PS);
    finally
    end;
  end;
end;

procedure TOpenGLWinControl.WMSize(var Message: TWMSize);
var w, h: integer; aspect: GLfloat;
begin
  if not(csDesigning in ComponentState) then begin
    w := self.Width;
    h := self.Height;
    glViewport(0, 0, w, h);
    glMatrixMode(GL_PROJECTION);
    glLoadIdentity();
    // 透视投影
    aspect := w;
    aspect := aspect / h;
    gluPerspective(30.0, aspect, 1.0, 50.0);
    glMatrixMode(GL_MODELVIEW);
    glLoadIdentity();
  end;
  inherited;
end;

end.

测试程序源码如下:

unit main;

interface

uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  OpenGLWinControl, Winapi.OpenGL, Vcl.ExtCtrls;

type
  TfrmMain = class(TForm)
    opnglwncntrl1: TOpenGLWinControl;
    tmr: TTimer;
    procedure opnglwncntrl1SetPixelFormatDescriptor(Sender: TObject);
    procedure opnglwncntrl1Paint(Sender: TObject);
    procedure tmrTimer(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.FormPaint(Sender: TObject);
begin
  self.opnglwncntrl1.Render;
end;

procedure TfrmMain.opnglwncntrl1Paint(Sender: TObject);
begin
  glClearColor(0.0, 0.0, 0.0, 1.0);
  glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
  SwapBuffers(wglGetCurrentDC);
end;

procedure TfrmMain.opnglwncntrl1SetPixelFormatDescriptor(Sender: TObject);
const pfd: TPIXELFORMATDESCRIPTOR = (nSize: sizeof(TPIXELFORMATDESCRIPTOR);
    // size
    nVersion: 1; // version
    dwFlags: PFD_SUPPORT_OPENGL or PFD_DRAW_TO_WINDOW or PFD_DOUBLEBUFFER;
    // support double-buffering
    iPixelType: PFD_TYPE_RGBA; // color type
    cColorBits: 24; // preferred color depth
    cRedBits: 0; cRedShift: 0; // color bits (ignored)
    cGreenBits: 0; cGreenShift: 0; cBlueBits: 0; cBlueShift: 0; cAlphaBits: 0;
    cAlphaShift: 0; // no alpha buffer
    cAccumBits: 0; cAccumRedBits: 0; // no accumulation buffer,
    cAccumGreenBits: 0; // accum bits (ignored)
    cAccumBlueBits: 0; cAccumAlphaBits: 0; cDepthBits: 16; // depth buffer
    cStencilBits: 0; // no stencil buffer
    cAuxBuffers: 0; // no auxiliary buffers
    iLayerType: PFD_MAIN_PLANE; // main layer
    bReserved: 0; dwLayerMask: 0; dwVisibleMask: 0; dwDamageMask: 0;
    // no layer, visible, damage masks
  );
var PixelFormat: Integer; r: Boolean;
begin
  ZeroMemory(@pfd, sizeof(PIXELFORMATDESCRIPTOR));
  PixelFormat := ChoosePixelFormat(opnglwncntrl1.HandleOfDeviceContex, @pfd);
  r := SetPixelFormat(opnglwncntrl1.HandleOfDeviceContex, PixelFormat, @pfd);
end;

procedure TfrmMain.tmrTimer(Sender: TObject);
begin
  self.opnglwncntrl1.Render;
end;

end.

界面如下:

object frmMain: TfrmMain
  Left = 0
  Top = 0
  Caption = 'OpenGL'#31243#24207#28436#31034
  ClientHeight = 665
  ClientWidth = 965
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  Position = poScreenCenter
  OnPaint = FormPaint
  PixelsPerInch = 96
  TextHeight = 13
  object opnglwncntrl1: TOpenGLWinControl
    Left = 176
    Top = 72
    Width = 441
    Height = 321
    OnSetPixelFormatDescriptor = opnglwncntrl1SetPixelFormatDescriptor
    OnPaint = opnglwncntrl1Paint
  end
  object tmr: TTimer
    Enabled = False
    Interval = 1
    OnTimer = tmrTimer
    Left = 808
    Top = 176
  end
end