unit1.pas

Delphi高级程序开发配书源代码,可以循序渐进的学习Delphi.

unit Unit1;

interface

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

type
  TGLControl=class(TCustomControl)
  public
   property OnMouseDown;
   property OnMouseUp;
   property OnMouseMove;
  end;
  TBodyType=(cone,cyllinder,sphere);
  TForm1 = class(TForm)
    TrackBar1: TTrackBar;
    Label1: TLabel;
    ComboBox1: TComboBox;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
  private
    //Mouse move block
    alpha, betha:GLfloat; //angle for mouse event
    dx,dy:GLFloat;        //current angle offsets
    mStartX,mStartY:integer; //start point for mouse move

    body:TBodyType;
    GLC:TGLControl; //control to incapsulate OpenGL output
    procedure Draw; //Draws an OpenGL scene on request
    //custom mouse down event for new control
    procedure GLMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    //custom mouse up event for new control
    procedure GLMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    //custom mouse move event for new control
    procedure GLMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure setupPixelFormat(DC:HDC);
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:16;				// prefered 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;
begin
  pixelFormat := ChoosePixelFormat(DC, @pfd);
  if (pixelFormat = 0) then begin
	MessageBox(WindowFromDC(DC), 'ChoosePixelFormat failed.', 'Error',
		MB_ICONERROR or MB_OK);
	exit;
  end;
  if (SetPixelFormat(DC, pixelFormat, @pfd) <> TRUE) then begin
	MessageBox(WindowFromDC(DC), 'SetPixelFormat failed.', 'Error',
		MB_ICONERROR or MB_OK);
	exit;
  end;
end;

procedure GLInit;
const
  light0_position:array [0..3] of GLfloat=( 4.0, 4.0, 4.0, 0.0);
  specular: array [0..3] of GLfloat=( 1.0, 1.0, 0.0, 1.0);
  diffuse:  array [0..3] of GLfloat=( 1.0, 1.0, 1.0, 0.7);
begin
   // set viewing projection */
   glMatrixMode(GL_PROJECTION);
   glFrustum(-0.1, 0.1, -0.1, 0.1, 0.3, 25.0);
   // position viewer */
   glMatrixMode(GL_MODELVIEW);
   glShadeModel(GL_FLAT);
   glEnable(GL_DEPTH_TEST);
   glEnable(GL_LIGHTING);
   //Lichtquelle
    glLightfv(GL_LIGHT0, GL_POSITION, @light0_position);
    glLightfv(GL_LIGHT0, GL_DIFFUSE,  @diffuse);
    glLightfv(GL_LIGHT0, GL_SPECULAR, @specular);

   glEnable(GL_LIGHT0);
   glEnable(GL_COLOR_MATERIAL);
end;



procedure TForm1.FormCreate(Sender: TObject);
var DC:HDC;
    RC:HGLRC;
begin
 //Create a control to run OpenGL on it.
 GLC:=TGLControl.Create(self);
 GLC.Parent:=self;
 GLC.Left:=10;
 GLC.Top:=10;
 GLC.Width:=300;
 GLC.Height:=300;
 //Get Device Context to create GLRC from it
 DC:=GetDC(GLC.Handle); //Actually, you can use any widowed control here
 //Set pixel format, so OpenGL can use this DC
 SetupPixelFormat(DC);
 RC:=wglCreateContext(DC); //make RC for DC
 wglMakeCurrent(DC, RC); //make my new OpenGL context active
 GLInit; //initialize basic OpenGL settings
 //connect our new GLC control events with custom functions
 GLC.OnMouseDown:=GLMouseDown;
 GLC.OnMouseMove:=GLMouseMove;
 GLC.OnMouseUp:=GLMouseUp;
 //setup body
 ComboBox1.ItemIndex:=0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 Draw;
end;

procedure TForm1.Draw;
var quad:GLUquadricObj;
begin
 glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
 glLoadIdentity;
 glTranslatef(0.0, 0.0, -TrackBar1.Position/10);
 glRotatef(alpha+dx,0.0,1.0,0.0);
 glRotatef(betha+dy,1.0,0.0,0.0);
 quad:=gluNewQuadric;
 case body of
  cone:gluCylinder(quad,0.5,0.0,1,48,1);
  cyllinder:gluCylinder(quad,0.5,0.5,1,48,1);
  sphere:gluSphere(quad,0.5,32,32);
 end;
 glTranslatef(-2,0,0);
 gluDeleteQuadric(quad);
 SwapBuffers(wglGetCurrentDC);
end;

procedure TForm1.TrackBar1Change(Sender: TObject);
begin
 Draw;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
 Draw;
end;

procedure TForm1.GLMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 Label1.Caption:=Format('down: %d, %d',[X,Y]);
 mStartX:=X;
 mStartY:=Y;
end;

procedure TForm1.GLMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
 Label1.Caption:=Format('up: %d, %d',[X,Y]);
 alpha:=alpha+dx;
 dx:=0.0;
 betha:=betha+dy;
 dy:=0.0;
end;

procedure TForm1.GLMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
 if (ssLeft in Shift) then begin
   Label1.Caption:=Format('move: %d, %d',[X,Y]);
   dx:=(x-mStartX)/2;
   dy:=(y-mStartY)/2;
   Draw;
 end;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
 body:=TBodyType(ComboBox1.ItemIndex);
 Draw;
end;

end.