
{*******************************************************}
{                                                       }
{       Komponent GLBox - Delphi                        }
{       Komponent dla biblioteki OpenGL                 }
{                                                       }
{       autor: Waldemara Pokuta - 2003                  }
{                                                       }
{*******************************************************}

unit GLBox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, OpenGL;

type
  PGlyphM = Windows.PGlyphMetricsFloat;
  TGLBox = class(TWinControl)
  private
    { Private declarations }
    FRender : TNotifyEvent;
    FSetupRC: TNotifyEvent;
    FResize : TNotifyEvent;
    procedure SetDCPixelFormat(Handle: HDC);
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); Message WM_ERASEBKGND;
    procedure WMPaint(var Message: TWMPaint); Message WM_PAINT;
    procedure WMSize(var Message: TWMSize); Message WM_SIZE;
  protected
    { Protected declarations }
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Render;
    procedure SetupRC;
    procedure Resize;
  public
    { Public declarations }
    DC: HDC;
    RC: HGLRC;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure CreateWnd; override;
    procedure MakeCurrent;
    procedure MakeNotCurrent;
    procedure BuildBitmapFont(FirstChar, CharCount, FontBase: integer);
    procedure BuildFont(FirstChar,CharCount,FontBase:integer;
                           Deviation,Thickness:Single;
                           DrawType:integer;gmf:PGlyphM);
  published
    { Published declarations }
    property OnRender : TNotifyEvent read FRender  write FRender;
    property OnSetupRC: TNotifyEvent read FSetupRC write FSetupRC;
    property OnResize : TNotifyEvent read FResize  write FResize;
    property OnKeyDown;
    property OnKeyUp;
    property OnKeyPress;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnStartDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;

    property TabStop;
    property TabOrder;
    property Align;
    property DragCursor;
    property DragMode;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Visible;
    property Font;
  end;

procedure Register;

implementation

procedure TGLBox.SetDCPixelFormat(Handle: HDC);
var
  pfd         : TPixelFormatDescriptor;
  nPixelFormat: integer;
begin
  FillChar(pfd, SizeOf(pfd), 0);
  with pfd do begin
    nSize     := SizeOf(pfd);
    nVersion  := 1;
    dwFlags   := PFD_DRAW_TO_WINDOW or
                 PFD_SUPPORT_OPENGL or
                 PFD_DOUBLEBUFFER;
    iPixelType:= PFD_TYPE_RGBA;
    cColorBits:= 24;
    cDepthBits:= 32;
    iLayerType:= PFD_MAIN_PLANE;
  end;
  nPixelFormat := ChoosePixelFormat(Handle, @pfd);
  SetPixelFormat(Handle, nPixelFormat, @pfd);
end;

procedure TGLBox.CreateParams(var Params: TCreateParams);
begin
  inherited;
  with Params do
  begin
    Style := Style or WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
    WindowClass.Style :=  CS_VREDRAW or CS_HREDRAW;
  end
end;

procedure TGLBox.MakeCurrent;
begin
  wglMakeCurrent(DC, RC);
end;

procedure TGLBox.MakeNotCurrent;
begin
  wglMakeCurrent(0, 0);
end;

constructor TGLBox.Create(AOwner: TComponent);
begin
  inherited;
  TabStop := true;
  height := 105;
  width := 105;
end;

destructor TGLBox.Destroy;
begin
  MakeNotCurrent;
  wglDeleteContext(RC);
  inherited;
end;

procedure TGLBox.CreateWnd;
var w, h : integer;
begin
  inherited;
  DC := GetDC(Handle);
  SetDCPixelFormat(DC);
  RC := wglCreateContext(DC);
  MakeCurrent;
  w := Width;
  h := Height;
  glViewPort(0, 0, w, h);
  SetupRC;
  glFlush;
  MakeNotCurrent;
end;

procedure TGLBox.WMPaint(var Message: TWMPaint);
var
  PS: TPaintStruct;
begin
  BeginPaint(Handle, PS);
  MakeCurrent;
  Render;
  glFlush;
  MakeNotCurrent;
  SwapBuffers(DC);
  EndPaint(Handle, PS);
  Message.Result := 0;
end;

procedure TGLBox.WMSize(var Message: TWMSize);
var w, h: integer;
begin
  w := Width;
  h := Height;
  if w = 0 then w := 1;
  if h = 0 then h := 1;
  MakeCurrent;
  glViewPort(0, 0, w, h);
  Resize;
  glFlush;
  MakeNotCurrent;
end;

procedure TGLBox.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TGLBox.BuildBitmapFont(FirstChar, CharCount, FontBase: integer);
begin
  SelectObject(DC, Font.Handle);
  wglUseFontBitmaps(DC,FirstChar,CharCount,FontBase);
end;

procedure TGLBox.BuildFont(FirstChar,CharCount,FontBase:integer;
                           Deviation,Thickness:Single;
                           DrawType:integer;gmf:PGlyphM);
begin
  SelectObject(DC, Font.Handle);
  wglUseFontOutlines(DC,FirstChar,CharCount,FontBase,
                     Deviation,Thickness,DrawType,gmf);
end;

//******************************************************************************
//******************   Zdarzenia w komponencie   *******************************
//******************************************************************************

procedure TGLBox.Render;
begin
  if Assigned(FRender) then FRender(self);
end;

procedure TGLBox.SetupRC;
begin
  if Assigned(FSetupRC) then FSetupRC(self);
end;

procedure TGLBox.Resize;
begin
  if Assigned(FResize) then FResize(self);
end;

procedure Register;
begin
  RegisterComponents('Samples', [TGLBox]);
end;

end.
