Y
yhllove
Unregistered / Unconfirmed
GUEST, unregistred user!
本小程序在D7下编译通过, 但在DLEPHI2005中无法编译,原因:
viewP :TviewPortArray;
modeM,projM :T16DArray;
两个变量找不到.本程序在WWW.2ccc.com有下载!!
http://www.2ccc.com/article.asp?articleid=211
program PickDemo;
uses
Windows, Messages, OpenGL, GL,GLu; // SysUtils,
const
WND_TITLE = 'OpenGL Pick Demo by inRm';
BUFSIZE = 32; // Size of selection buffer.
type
gl1f = glfloat;
gl3f = array [0..2] of glfloat;
gl4f = array [0..3] of glfloat;
var
h_Wnd : HWND; // Global window handle
h_DC : HDC; // Global device context
h_RC : HGLRC; // OpenGL rendering context
winW : integer=800; // window size
winH : integer=600;
keys : Array[0..255] of Boolean; // Holds keystrokes
viewP :TviewPortArray;
modeM,projM :T16DArray;
// User vaiables
Ldown,Rdown :boolean;
hit,eye : Integer;
zPos :Tpoint;
x0, y0 :Integer; // mouse movement
rx, ry :single;
// Object position
obj :array[1..2] of gl3f; //对象的空间坐标
Pos :array[1..2] of gl3f; //对象的屏幕坐标
{------------------------------------------------------------------}
{ Function to convert int to string. }
{------------------------------------------------------------------}
function IntToStr(Num : Integer) : String;
begin
Str(Num, result);
end;
function Vert( x,y,z :gl1f) :gl3f;
begin
result[0]:=x; result[1]:=y; result[2]:=z;
end;
function Point(X, Y: Integer): TPoint;
begin
Result.X:= X; Result.Y:= Y;
end;
procedure setAxisList;
begin
glNewList(1,GL_COMPILE); //坐标线
glColor3f(1,0.5,0.5); glLineWidth (1);//绘图直线时笔的宽度
glBegin(GL_LINE_STRIP);
glColor3f(1,0,1); glVertex3f( 0,0,0); glVertex3f( 4,0,0);
glColor3f(0,1,0); glVertex3f( 0,0,0); glVertex3f( 0,3,0);
glColor3f(0,0,1); glVertex3f( 0,0,0); glVertex3f( 0,0,2);
glEnd;
glEndList;
end;
{------------------------------------------------------------------}
{ Function to draw the actual scene }
{------------------------------------------------------------------}
procedure glDraw( Mode :integer);
var h :integer;
begin
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); // Clear The Screen And The Depth Buffer
glLoadIdentity(); // Reset The View
glTranslatef(0,0,-eye);
glRotatef( ry, 1,0,0);
glRotatef( rx, 0,0,1);
glColor3f(0, 0.1, 0.6);
glCallList(1);
glPointSize( 6); glLineWidth(2);
if mode = GL_SELECT then glLoadName(1);
glBegin(GL_POINTS); glColor3f(1, 1, 0);
if hit=1 then glColor3f(1, 0, 0) else glColor3f(1, 1, 0);
glVertex3fv( @obj[1]); //画第一点
glEnd;
if mode = GL_SELECT then glLoadName(2);
glBegin(GL_POINTS); glColor3f(1, 1, 0);
if hit=2 then glColor3f(1, 0, 0) else glColor3f(1, 1, 0);
glVertex3fv( @obj[2]); //画第二点
glEnd;
if mode = GL_SELECT then glLoadName(3);
glBegin( GL_LINES);
if hit=3 then glColor3f(1, 0, 0) else glColor3f(1, 0.5, 0.5);
glVertex3fv( @obj[1]); glVertex3fv( @obj[2]); //连接线
glEnd;
if mode = GL_SELECT then glLoadName(0);
glCallList(1); //画坐标轴线
if Ldown and(hit>0) then begin //画坐标指示线
glColor3f( 0.5,0.5,0.5);
glEnable( GL_LINE_STIPPLE); glLineStipple(1,$4444);
if hit<3 then h:=hit else h:=1;
glBegin( GL_LINE_STRIP);
glVertex3fv( @obj[h]); glVertex3f( obj[h,0],obj[h,1],0);
glVertex3f( obj[h,0],0,0); glVertex3f( 0,0,0);
glVertex3f( 0,obj[h,1],0); glVertex3f( obj[h,0],obj[h,1],0);
glEnd;
glDisable( GL_LINE_STIPPLE);
end;
end;
{------------------------------------------------------------------}
{ Initialise OpenGL }
{------------------------------------------------------------------}
procedure glInit();
begin
glClearColor(0.0, 0.0, 0.0, 0.0); // Black Background
// glShadeModel(GL_SMOOTH); // Enables Smooth Color Shading
glClearDepth(1.0); // Depth Buffer Setup
glDepthFunc(GL_LESS); // The Type Of Depth Test To Do
glEnable(GL_DEPTH_TEST); // Enable Depth Buffer
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST); //Realy Nice perspective calculations
glBlendFunc (GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); //控制混合方式
glEnable(GL_BLEND); //混合(透明)使能
glEnable(GL_line_smooth);
glEnable(GL_POINT_SMOOTH);
setAxisList;
rx:= -125; ry:= -65; //视角
eye:= 10; //景深
obj[1]:=Vert(-1, 2, 0.8);
obj[2]:=Vert( 2,-1,-0.5);
end;
{------------------------------------------------------------------}
{ Handle window resize }
{------------------------------------------------------------------}
procedure glResizeWnd(Width, Height : Integer);
begin
winW:= width; winH:= Height;
if (Height = 0) then Height := 1; // prevent divide by zero exception
glViewport(0, 0, Width, Height); // Set the viewport for the OpenGL window
glMatrixMode(GL_PROJECTION); // Change Matrix Mode to Projection
glLoadIdentity(); // Reset View
gluPerspective(45, Width/Height, 1, 100); // Do the perspective calculations. Last value = max clipping depth
glMatrixMode(GL_MODELVIEW); // Return to the modelview matrix
glLoadIdentity(); // Reset View
end;
{------------------------------------------------------------------}
{ Processes all mouse Clicks }
{------------------------------------------------------------------}
function doSelect(X, Y : Integer) :integer;
var selectBuff : Array[0..23] of glUint;
begin
glGetIntegerv(GL_VIEWPORT, @viewP); // Viewport = [0, 0, width, height]
glSelectBuffer(BUFSIZE, @selectBuff);
glRenderMode(GL_SELECT);
glInitNames;
glPushName(32);
glMatrixMode(GL_PROJECTION);
glPushMatrix();
glLoadIdentity();
gluPickMatrix(x, winH-y, 4, 4, viewP); // Set-up pick matrix
gluPerspective(45, winW/winH, 1, 100); // Do the perspective calculations. Last value = max clipping depth
glMatrixMode(GL_MODELVIEW);
glDraw( GL_SELECT);
glMatrixMode(GL_PROJECTION);
glPopMatrix();
glMatrixMode(GL_MODELVIEW);
if glRenderMode(GL_RENDER)>0
then result:= selectBuff[3]
else result:= -1;
end;
//############ 获得对象的屏幕坐标 ################
function GetWinPos( h:integer) :gl3f;
var wx,wy,wz :glDouble; // 屏幕坐标
begin
gluProject( obj[h,0],obj[h,1],obj[h,2], modeM,projM,viewP, @wx,@wy,@wz);
result:= Vert( wx,wy,wz);
end;
//############ 将屏幕坐标转换为空间坐标 ################
function GetObjPos( x,y,z:gl1f) :gl3f;
var px,py,pz :glDouble; // 对象坐标
begin
gluUnProject( x,y,z, modeM,projM,viewP, @px,@py,@pz);
result:= Vert( px,py,pz);
end;
//============ 按下鼠标 =============
procedure MouseDown( hit, x,y : Integer);
var i :integer;
begin
Ldown:= TRUE;
if hit<=0 then exit;
zPos:= point(x,y); //很奇怪，这个变量无任何用处，但在这里却不能删除，否则就会黑屏！
glGetDoublev( GL_Modelview_Matrix, @modeM);
glGetDoublev(GL_Projection_Matrix, @projM);
for i:= 1 to 2 do Pos:= GetWinPos(i);//构件的屏幕坐标
glDraw(GL_RENDER);
end;
//============= 移动鼠标 ==============
procedure MouseMove( hit, x,y, x0,y0 : Integer);
var dx,dy, i :integer;
begin
dx:= x-x0; dy:= y-y0;
if hit<0 then begin rx:= rx+ (x-x0)/5; ry:= ry+ (y-y0)/5; end; //改变视角
if hit<3 then
obj[hit]:= GetObjPos( x, winH-y, GetWinPos( hit)[2]); //直接将构件移动到新的位置
if hit=3 then
for i:= 1 to 2 do
begin
obj:= GetObjPos( Pos[0]+dx,(Pos[1]-dy),Pos[2]);//将构件移动到新的位置
Pos:= GetWinPos(i);//构件的屏幕坐标
end;
end;
{------------------------------------------------------------------}
{ Determines the application抯 response to the messages received }
{------------------------------------------------------------------}
function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var x,y :integer;
begin
case (Msg) of
WM_CREATE:
begin
// Insert stuff you want executed when the program starts
end;
WM_CLOSE:
begin
PostQuitMessage(0);
Result := 0
end;
WM_KEYDOWN: // Set the pressed key (wparam) to equal true so we can check if its pressed
begin
keys[wParam] := True;
Result := 0;
end;
WM_KEYUP: // Set the released key (wparam) to equal false so we can check if its pressed
begin
keys[wParam] := False;
Result := 0;
end;
WM_SIZE: // Resize the window with the new width and height
begin
glResizeWnd(LOWORD(lParam),HIWORD(lParam));
Result := 0;
end;
WM_LBUTTONDOWN: begin
x0:= LoWord(lParam); y0:= HiWord(lParam);
MouseDown( hit, x0,y0 );
Result := 0;
end;
WM_RBUTTONDOWN: begin
x0:= LoWord(lParam); y0:= HiWord(lParam);
Rdown:= true;
Result := 0;
end;
WM_LBUTTONUP: begin
Ldown :=FALSE;
Result := 0;
end;
WM_RBUTTONUP: begin
Rdown :=FALSE;
Result := 0;
end;
WM_MOUSEMOVE:begin
x:= LoWord(lParam); y:= HiWord(lParam);
if not(Ldown or Rdown) then hit:= doSelect(x, y); //自由移动
if Ldown then MouseMove( hit, x,y, x0,y0); //拖动左键
if Rdown then begin //拖动右键
eye:= eye- (x-x0); //改变景深
if eye>80 then eye:=80; if eye<5 then eye:=5;
end;
x0:= x; y0:= y;
SetWindowText(h_Wnd, PChar('OpenGL Pick Demo by inRm ... Object number: '+IntToStr(hit)));
Result := 0;
end;
WM_TIMER:
// Add code here for all timers to be used.
else
Result := DefWindowProc(hWnd, Msg, wParam, lParam); // Default result if nothing happens
end;
end;
{---------------------------------------------------------------------}
{ Properly destroys the window created at startup (no memory leaks) }
{---------------------------------------------------------------------}
procedure glKillWnd(Fullscreen : Boolean);
begin
if Fullscreen then // Change back to non fullscreen
begin
ChangeDisplaySettings(devmode(nil^), 0);
ShowCursor(True);
end;
// Makes current rendering context not current, and releases the device
// context that is used by the rendering context.
if (not wglMakeCurrent(h_DC, 0)) then
MessageBox(0, 'Release of DC and RC failed!', 'Error', MB_OK or MB_ICONERROR);
// Attempts to delete the rendering context
if (not wglDeleteContext(h_RC)) then
begin
MessageBox(0, 'Release of rendering context failed!', 'Error', MB_OK or MB_ICONERROR);
h_RC := 0;
end;
// Attemps to release the device context
if ((h_DC = 1) and (ReleaseDC(h_Wnd, h_DC) <> 0)) then
begin
MessageBox(0, 'Release of device context failed!', 'Error', MB_OK or MB_ICONERROR);
h_DC := 0;
end;
// Attempts to destroy the window
if ((h_Wnd <> 0) and (not DestroyWindow(h_Wnd))) then
begin
MessageBox(0, 'Unable to destroy window!', 'Error', MB_OK or MB_ICONERROR);
h_Wnd := 0;
end;
// Attempts to unregister the window class
if (not UnRegisterClass('OpenGL', hInstance)) then
begin
MessageBox(0, 'Unable to unregister window class!', 'Error', MB_OK or MB_ICONERROR);
hInstance := 0;
end;
end;
{--------------------------------------------------------------------}
{ Creates the window and attaches a OpenGL rendering context to it }
{--------------------------------------------------------------------}
function glCreateWnd(Width, Height : Integer; Fullscreen : Boolean; PixelDepth : Integer) : Boolean;
var
wndClass : TWndClass; // Window class
dwStyle : DWORD; // Window styles
dwExStyle : DWORD; // Extended window styles
dmScreenSettings : DEVMODE; // Screen settings (fullscreen, etc...)
PixelFormat : GLuint; // Settings for the OpenGL rendering
h_Instance : HINST; // Current instance
pfd : TPIXELFORMATDESCRIPTOR; // Settings for the OpenGL window
begin
h_Instance := GetModuleHandle(nil); //Grab An Instance For Our Window
ZeroMemory(@wndClass, SizeOf(wndClass)); // Clear the window class structure
with wndClass do // Set up the window class
begin
style := CS_HREDRAW or // Redraws entire window if length changes
CS_VREDRAW or // Redraws entire window if height changes
CS_OWNDC; // Unique device context for the window
lpfnWndProc := @WndProc; // Set the window procedure to our func WndProc
hInstance := h_Instance;
hCursor := LoadCursor(0, IDC_ARROW);
lpszClassName := 'OpenGL';
end;
if (RegisterClass(wndClass) = 0) then // Attemp to register the window class
begin
MessageBox(0, 'Failed to register the window class!', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit
end;
// Change to fullscreen if so desired
if Fullscreen then
begin
ZeroMemory(@dmScreenSettings, SizeOf(dmScreenSettings));
with dmScreenSettings do begin // Set parameters for the screen setting
dmSize := SizeOf(dmScreenSettings);
dmPelsWidth := Width; // Window width
dmPelsHeight := Height; // Window height
dmBitsPerPel := PixelDepth; // Window color depth
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL;
end;
// Try to change screen mode to fullscreen
if (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN) = DISP_CHANGE_FAILED) then
begin
MessageBox(0, 'Unable to switch to fullscreen!', 'Error', MB_OK or MB_ICONERROR);
Fullscreen := False;
end;
end;
// If we are still in fullscreen then
if (Fullscreen) then
begin
dwStyle := WS_POPUP or // Creates a popup window
WS_CLIPCHILDREN // Doesn't draw within child windows
or WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
dwExStyle := WS_EX_APPWINDOW; // Top level window
ShowCursor(False); // Turn of the cursor (gets in the way)
end
else
begin
dwStyle := WS_OVERLAPPEDWINDOW or // Creates an overlapping window
WS_CLIPCHILDREN or // Doesn't draw within child windows
WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
dwExStyle := WS_EX_APPWINDOW or // Top level window
WS_EX_WINDOWEDGE; // Border with a raised edge
end;
// Attempt to create the actual window
h_Wnd := CreateWindowEx(dwExStyle, // Extended window styles
'OpenGL', // Class name
WND_TITLE, // Window title (caption)
dwStyle, // Window styles
0, 0, // Window position
Width, Height+27, // Size of window
0, // No parent window
0, // No menu
h_Instance, // Instance
nil); // Pass nothing to WM_CREATE
if h_Wnd = 0 then
begin
glKillWnd(Fullscreen); // Undo all the settings we've changed
MessageBox(0, 'Unable to create window!', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Try to get a device context
h_DC := GetDC(h_Wnd);
if (h_DC = 0) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to get a device context!', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Settings for the OpenGL window
with pfd do
begin
nSize := SizeOf(TPIXELFORMATDESCRIPTOR); // Size Of This Pixel Format Descriptor
nVersion := 1; // The version of this data structure
dwFlags := PFD_DRAW_TO_WINDOW // Buffer supports drawing to window
or PFD_SUPPORT_OPENGL // Buffer supports OpenGL drawing
or PFD_DOUBLEBUFFER; // Supports double buffering
iPixelType := PFD_TYPE_RGBA; // RGBA color format
cColorBits := PixelDepth; // OpenGL color depth
cRedBits := 0; // Number of red bitplanes
cRedShift := 0; // Shift count for red bitplanes
cGreenBits := 0; // Number of green bitplanes
cGreenShift := 0; // Shift count for green bitplanes
cBlueBits := 0; // Number of blue bitplanes
cBlueShift := 0; // Shift count for blue bitplanes
cAlphaBits := 0; // Not supported
cAlphaShift := 0; // Not supported
cAccumBits := 0; // No accumulation buffer
cAccumRedBits := 0; // Number of red bits in a-buffer
cAccumGreenBits := 0; // Number of green bits in a-buffer
cAccumBlueBits := 0; // Number of blue bits in a-buffer
cAccumAlphaBits := 0; // Number of alpha bits in a-buffer
cDepthBits := 16; // Specifies the depth of the depth buffer
cStencilBits := 0; // Turn off stencil buffer
cAuxBuffers := 0; // Not supported
iLayerType := PFD_MAIN_PLANE; // Ignored
bReserved := 0; // Number of overlay and underlay planes
dwLayerMask := 0; // Ignored
dwVisibleMask := 0; // Transparent color of underlay plane
dwDamageMask := 0; // Ignored
end;
// Attempts to find the pixel format supported by a device context that is the best match to a given pixel format specification.
PixelFormat := ChoosePixelFormat(h_DC, @pfd);
if (PixelFormat = 0) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to find a suitable pixel format', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Sets the specified device context's pixel format to the format specified by the PixelFormat.
if (not SetPixelFormat(h_DC, PixelFormat, @pfd)) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to set the pixel format', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Create a OpenGL rendering context
h_RC := wglCreateContext(h_DC);
if (h_RC = 0) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to create an OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Makes the specified OpenGL rendering context the calling thread's current rendering context
if (not wglMakeCurrent(h_DC, h_RC)) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to activate OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Settings to ensure that the window is the topmost window
ShowWindow(h_Wnd, SW_SHOW);
SetForegroundWindow(h_Wnd);
SetFocus(h_Wnd);
// Ensure the OpenGL window is resized properly
glResizeWnd(Width, Height);
glInit();
Result := True;
end;
{--------------------------------------------------------------------}
{ Main message loop for the application }
{--------------------------------------------------------------------}
function WinMain(hInstance :HINST; hPrevInstance :HINST; lpCmdLine
Char; nCmdShow :Integer) :Integer; stdcall;
var
msg : TMsg;
finished : Boolean;
begin
finished := False;
// Perform application initialization:
if not glCreateWnd(800, 600, false, 32) then
begin
Result := 0;
Exit;
end;
// Main message loop:
while not finished do
begin
if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then // Check if there is a message for this window
begin
if (msg.message = WM_QUIT) // If WM_QUIT message received then we are done
then finished := True
else begin // Else translate and dispatch the message to this window
TranslateMessage(msg);
DispatchMessage(msg);
end;
end
else
begin
glDraw(GL_RENDER); // Draw the scene
SwapBuffers(h_DC); // Display the scene
if(keys[VK_ESCAPE])then finished := True; // If user pressed ESC then set finised TRUE
end;
end;
glKillWnd(FALSE);
Result := msg.wParam;
end;
begin
WinMain( hInstance, hPrevInst, CmdLine, CmdShow );
end.
viewP :TviewPortArray;
modeM,projM :T16DArray;
两个变量找不到.本程序在WWW.2ccc.com有下载!!
http://www.2ccc.com/article.asp?articleid=211
program PickDemo;
uses
Windows, Messages, OpenGL, GL,GLu; // SysUtils,
const
WND_TITLE = 'OpenGL Pick Demo by inRm';
BUFSIZE = 32; // Size of selection buffer.
type
gl1f = glfloat;
gl3f = array [0..2] of glfloat;
gl4f = array [0..3] of glfloat;
var
h_Wnd : HWND; // Global window handle
h_DC : HDC; // Global device context
h_RC : HGLRC; // OpenGL rendering context
winW : integer=800; // window size
winH : integer=600;
keys : Array[0..255] of Boolean; // Holds keystrokes
viewP :TviewPortArray;
modeM,projM :T16DArray;
// User vaiables
Ldown,Rdown :boolean;
hit,eye : Integer;
zPos :Tpoint;
x0, y0 :Integer; // mouse movement
rx, ry :single;
// Object position
obj :array[1..2] of gl3f; //对象的空间坐标
Pos :array[1..2] of gl3f; //对象的屏幕坐标
{------------------------------------------------------------------}
{ Function to convert int to string. }
{------------------------------------------------------------------}
function IntToStr(Num : Integer) : String;
begin
Str(Num, result);
end;
function Vert( x,y,z :gl1f) :gl3f;
begin
result[0]:=x; result[1]:=y; result[2]:=z;
end;
function Point(X, Y: Integer): TPoint;
begin
Result.X:= X; Result.Y:= Y;
end;
procedure setAxisList;
begin
glNewList(1,GL_COMPILE); //坐标线
glColor3f(1,0.5,0.5); glLineWidth (1);//绘图直线时笔的宽度
glBegin(GL_LINE_STRIP);
glColor3f(1,0,1); glVertex3f( 0,0,0); glVertex3f( 4,0,0);
glColor3f(0,1,0); glVertex3f( 0,0,0); glVertex3f( 0,3,0);
glColor3f(0,0,1); glVertex3f( 0,0,0); glVertex3f( 0,0,2);
glEnd;
glEndList;
end;
{------------------------------------------------------------------}
{ Function to draw the actual scene }
{------------------------------------------------------------------}
procedure glDraw( Mode :integer);
var h :integer;
begin
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); // Clear The Screen And The Depth Buffer
glLoadIdentity(); // Reset The View
glTranslatef(0,0,-eye);
glRotatef( ry, 1,0,0);
glRotatef( rx, 0,0,1);
glColor3f(0, 0.1, 0.6);
glCallList(1);
glPointSize( 6); glLineWidth(2);
if mode = GL_SELECT then glLoadName(1);
glBegin(GL_POINTS); glColor3f(1, 1, 0);
if hit=1 then glColor3f(1, 0, 0) else glColor3f(1, 1, 0);
glVertex3fv( @obj[1]); //画第一点
glEnd;
if mode = GL_SELECT then glLoadName(2);
glBegin(GL_POINTS); glColor3f(1, 1, 0);
if hit=2 then glColor3f(1, 0, 0) else glColor3f(1, 1, 0);
glVertex3fv( @obj[2]); //画第二点
glEnd;
if mode = GL_SELECT then glLoadName(3);
glBegin( GL_LINES);
if hit=3 then glColor3f(1, 0, 0) else glColor3f(1, 0.5, 0.5);
glVertex3fv( @obj[1]); glVertex3fv( @obj[2]); //连接线
glEnd;
if mode = GL_SELECT then glLoadName(0);
glCallList(1); //画坐标轴线
if Ldown and(hit>0) then begin //画坐标指示线
glColor3f( 0.5,0.5,0.5);
glEnable( GL_LINE_STIPPLE); glLineStipple(1,$4444);
if hit<3 then h:=hit else h:=1;
glBegin( GL_LINE_STRIP);
glVertex3fv( @obj[h]); glVertex3f( obj[h,0],obj[h,1],0);
glVertex3f( obj[h,0],0,0); glVertex3f( 0,0,0);
glVertex3f( 0,obj[h,1],0); glVertex3f( obj[h,0],obj[h,1],0);
glEnd;
glDisable( GL_LINE_STIPPLE);
end;
end;
{------------------------------------------------------------------}
{ Initialise OpenGL }
{------------------------------------------------------------------}
procedure glInit();
begin
glClearColor(0.0, 0.0, 0.0, 0.0); // Black Background
// glShadeModel(GL_SMOOTH); // Enables Smooth Color Shading
glClearDepth(1.0); // Depth Buffer Setup
glDepthFunc(GL_LESS); // The Type Of Depth Test To Do
glEnable(GL_DEPTH_TEST); // Enable Depth Buffer
glHint(GL_PERSPECTIVE_CORRECTION_HINT, GL_NICEST); //Realy Nice perspective calculations
glBlendFunc (GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); //控制混合方式
glEnable(GL_BLEND); //混合(透明)使能
glEnable(GL_line_smooth);
glEnable(GL_POINT_SMOOTH);
setAxisList;
rx:= -125; ry:= -65; //视角
eye:= 10; //景深
obj[1]:=Vert(-1, 2, 0.8);
obj[2]:=Vert( 2,-1,-0.5);
end;
{------------------------------------------------------------------}
{ Handle window resize }
{------------------------------------------------------------------}
procedure glResizeWnd(Width, Height : Integer);
begin
winW:= width; winH:= Height;
if (Height = 0) then Height := 1; // prevent divide by zero exception
glViewport(0, 0, Width, Height); // Set the viewport for the OpenGL window
glMatrixMode(GL_PROJECTION); // Change Matrix Mode to Projection
glLoadIdentity(); // Reset View
gluPerspective(45, Width/Height, 1, 100); // Do the perspective calculations. Last value = max clipping depth
glMatrixMode(GL_MODELVIEW); // Return to the modelview matrix
glLoadIdentity(); // Reset View
end;
{------------------------------------------------------------------}
{ Processes all mouse Clicks }
{------------------------------------------------------------------}
function doSelect(X, Y : Integer) :integer;
var selectBuff : Array[0..23] of glUint;
begin
glGetIntegerv(GL_VIEWPORT, @viewP); // Viewport = [0, 0, width, height]
glSelectBuffer(BUFSIZE, @selectBuff);
glRenderMode(GL_SELECT);
glInitNames;
glPushName(32);
glMatrixMode(GL_PROJECTION);
glPushMatrix();
glLoadIdentity();
gluPickMatrix(x, winH-y, 4, 4, viewP); // Set-up pick matrix
gluPerspective(45, winW/winH, 1, 100); // Do the perspective calculations. Last value = max clipping depth
glMatrixMode(GL_MODELVIEW);
glDraw( GL_SELECT);
glMatrixMode(GL_PROJECTION);
glPopMatrix();
glMatrixMode(GL_MODELVIEW);
if glRenderMode(GL_RENDER)>0
then result:= selectBuff[3]
else result:= -1;
end;
//############ 获得对象的屏幕坐标 ################
function GetWinPos( h:integer) :gl3f;
var wx,wy,wz :glDouble; // 屏幕坐标
begin
gluProject( obj[h,0],obj[h,1],obj[h,2], modeM,projM,viewP, @wx,@wy,@wz);
result:= Vert( wx,wy,wz);
end;
//############ 将屏幕坐标转换为空间坐标 ################
function GetObjPos( x,y,z:gl1f) :gl3f;
var px,py,pz :glDouble; // 对象坐标
begin
gluUnProject( x,y,z, modeM,projM,viewP, @px,@py,@pz);
result:= Vert( px,py,pz);
end;
//============ 按下鼠标 =============
procedure MouseDown( hit, x,y : Integer);
var i :integer;
begin
Ldown:= TRUE;
if hit<=0 then exit;
zPos:= point(x,y); //很奇怪，这个变量无任何用处，但在这里却不能删除，否则就会黑屏！
glGetDoublev( GL_Modelview_Matrix, @modeM);
glGetDoublev(GL_Projection_Matrix, @projM);
for i:= 1 to 2 do Pos:= GetWinPos(i);//构件的屏幕坐标
glDraw(GL_RENDER);
end;
//============= 移动鼠标 ==============
procedure MouseMove( hit, x,y, x0,y0 : Integer);
var dx,dy, i :integer;
begin
dx:= x-x0; dy:= y-y0;
if hit<0 then begin rx:= rx+ (x-x0)/5; ry:= ry+ (y-y0)/5; end; //改变视角
if hit<3 then
obj[hit]:= GetObjPos( x, winH-y, GetWinPos( hit)[2]); //直接将构件移动到新的位置
if hit=3 then
for i:= 1 to 2 do
begin
obj:= GetObjPos( Pos[0]+dx,(Pos[1]-dy),Pos[2]);//将构件移动到新的位置
Pos:= GetWinPos(i);//构件的屏幕坐标
end;
end;
{------------------------------------------------------------------}
{ Determines the application抯 response to the messages received }
{------------------------------------------------------------------}
function WndProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var x,y :integer;
begin
case (Msg) of
WM_CREATE:
begin
// Insert stuff you want executed when the program starts
end;
WM_CLOSE:
begin
PostQuitMessage(0);
Result := 0
end;
WM_KEYDOWN: // Set the pressed key (wparam) to equal true so we can check if its pressed
begin
keys[wParam] := True;
Result := 0;
end;
WM_KEYUP: // Set the released key (wparam) to equal false so we can check if its pressed
begin
keys[wParam] := False;
Result := 0;
end;
WM_SIZE: // Resize the window with the new width and height
begin
glResizeWnd(LOWORD(lParam),HIWORD(lParam));
Result := 0;
end;
WM_LBUTTONDOWN: begin
x0:= LoWord(lParam); y0:= HiWord(lParam);
MouseDown( hit, x0,y0 );
Result := 0;
end;
WM_RBUTTONDOWN: begin
x0:= LoWord(lParam); y0:= HiWord(lParam);
Rdown:= true;
Result := 0;
end;
WM_LBUTTONUP: begin
Ldown :=FALSE;
Result := 0;
end;
WM_RBUTTONUP: begin
Rdown :=FALSE;
Result := 0;
end;
WM_MOUSEMOVE:begin
x:= LoWord(lParam); y:= HiWord(lParam);
if not(Ldown or Rdown) then hit:= doSelect(x, y); //自由移动
if Ldown then MouseMove( hit, x,y, x0,y0); //拖动左键
if Rdown then begin //拖动右键
eye:= eye- (x-x0); //改变景深
if eye>80 then eye:=80; if eye<5 then eye:=5;
end;
x0:= x; y0:= y;
SetWindowText(h_Wnd, PChar('OpenGL Pick Demo by inRm ... Object number: '+IntToStr(hit)));
Result := 0;
end;
WM_TIMER:
// Add code here for all timers to be used.
else
Result := DefWindowProc(hWnd, Msg, wParam, lParam); // Default result if nothing happens
end;
end;
{---------------------------------------------------------------------}
{ Properly destroys the window created at startup (no memory leaks) }
{---------------------------------------------------------------------}
procedure glKillWnd(Fullscreen : Boolean);
begin
if Fullscreen then // Change back to non fullscreen
begin
ChangeDisplaySettings(devmode(nil^), 0);
ShowCursor(True);
end;
// Makes current rendering context not current, and releases the device
// context that is used by the rendering context.
if (not wglMakeCurrent(h_DC, 0)) then
MessageBox(0, 'Release of DC and RC failed!', 'Error', MB_OK or MB_ICONERROR);
// Attempts to delete the rendering context
if (not wglDeleteContext(h_RC)) then
begin
MessageBox(0, 'Release of rendering context failed!', 'Error', MB_OK or MB_ICONERROR);
h_RC := 0;
end;
// Attemps to release the device context
if ((h_DC = 1) and (ReleaseDC(h_Wnd, h_DC) <> 0)) then
begin
MessageBox(0, 'Release of device context failed!', 'Error', MB_OK or MB_ICONERROR);
h_DC := 0;
end;
// Attempts to destroy the window
if ((h_Wnd <> 0) and (not DestroyWindow(h_Wnd))) then
begin
MessageBox(0, 'Unable to destroy window!', 'Error', MB_OK or MB_ICONERROR);
h_Wnd := 0;
end;
// Attempts to unregister the window class
if (not UnRegisterClass('OpenGL', hInstance)) then
begin
MessageBox(0, 'Unable to unregister window class!', 'Error', MB_OK or MB_ICONERROR);
hInstance := 0;
end;
end;
{--------------------------------------------------------------------}
{ Creates the window and attaches a OpenGL rendering context to it }
{--------------------------------------------------------------------}
function glCreateWnd(Width, Height : Integer; Fullscreen : Boolean; PixelDepth : Integer) : Boolean;
var
wndClass : TWndClass; // Window class
dwStyle : DWORD; // Window styles
dwExStyle : DWORD; // Extended window styles
dmScreenSettings : DEVMODE; // Screen settings (fullscreen, etc...)
PixelFormat : GLuint; // Settings for the OpenGL rendering
h_Instance : HINST; // Current instance
pfd : TPIXELFORMATDESCRIPTOR; // Settings for the OpenGL window
begin
h_Instance := GetModuleHandle(nil); //Grab An Instance For Our Window
ZeroMemory(@wndClass, SizeOf(wndClass)); // Clear the window class structure
with wndClass do // Set up the window class
begin
style := CS_HREDRAW or // Redraws entire window if length changes
CS_VREDRAW or // Redraws entire window if height changes
CS_OWNDC; // Unique device context for the window
lpfnWndProc := @WndProc; // Set the window procedure to our func WndProc
hInstance := h_Instance;
hCursor := LoadCursor(0, IDC_ARROW);
lpszClassName := 'OpenGL';
end;
if (RegisterClass(wndClass) = 0) then // Attemp to register the window class
begin
MessageBox(0, 'Failed to register the window class!', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit
end;
// Change to fullscreen if so desired
if Fullscreen then
begin
ZeroMemory(@dmScreenSettings, SizeOf(dmScreenSettings));
with dmScreenSettings do begin // Set parameters for the screen setting
dmSize := SizeOf(dmScreenSettings);
dmPelsWidth := Width; // Window width
dmPelsHeight := Height; // Window height
dmBitsPerPel := PixelDepth; // Window color depth
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT or DM_BITSPERPEL;
end;
// Try to change screen mode to fullscreen
if (ChangeDisplaySettings(dmScreenSettings, CDS_FULLSCREEN) = DISP_CHANGE_FAILED) then
begin
MessageBox(0, 'Unable to switch to fullscreen!', 'Error', MB_OK or MB_ICONERROR);
Fullscreen := False;
end;
end;
// If we are still in fullscreen then
if (Fullscreen) then
begin
dwStyle := WS_POPUP or // Creates a popup window
WS_CLIPCHILDREN // Doesn't draw within child windows
or WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
dwExStyle := WS_EX_APPWINDOW; // Top level window
ShowCursor(False); // Turn of the cursor (gets in the way)
end
else
begin
dwStyle := WS_OVERLAPPEDWINDOW or // Creates an overlapping window
WS_CLIPCHILDREN or // Doesn't draw within child windows
WS_CLIPSIBLINGS; // Doesn't draw within sibling windows
dwExStyle := WS_EX_APPWINDOW or // Top level window
WS_EX_WINDOWEDGE; // Border with a raised edge
end;
// Attempt to create the actual window
h_Wnd := CreateWindowEx(dwExStyle, // Extended window styles
'OpenGL', // Class name
WND_TITLE, // Window title (caption)
dwStyle, // Window styles
0, 0, // Window position
Width, Height+27, // Size of window
0, // No parent window
0, // No menu
h_Instance, // Instance
nil); // Pass nothing to WM_CREATE
if h_Wnd = 0 then
begin
glKillWnd(Fullscreen); // Undo all the settings we've changed
MessageBox(0, 'Unable to create window!', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Try to get a device context
h_DC := GetDC(h_Wnd);
if (h_DC = 0) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to get a device context!', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Settings for the OpenGL window
with pfd do
begin
nSize := SizeOf(TPIXELFORMATDESCRIPTOR); // Size Of This Pixel Format Descriptor
nVersion := 1; // The version of this data structure
dwFlags := PFD_DRAW_TO_WINDOW // Buffer supports drawing to window
or PFD_SUPPORT_OPENGL // Buffer supports OpenGL drawing
or PFD_DOUBLEBUFFER; // Supports double buffering
iPixelType := PFD_TYPE_RGBA; // RGBA color format
cColorBits := PixelDepth; // OpenGL color depth
cRedBits := 0; // Number of red bitplanes
cRedShift := 0; // Shift count for red bitplanes
cGreenBits := 0; // Number of green bitplanes
cGreenShift := 0; // Shift count for green bitplanes
cBlueBits := 0; // Number of blue bitplanes
cBlueShift := 0; // Shift count for blue bitplanes
cAlphaBits := 0; // Not supported
cAlphaShift := 0; // Not supported
cAccumBits := 0; // No accumulation buffer
cAccumRedBits := 0; // Number of red bits in a-buffer
cAccumGreenBits := 0; // Number of green bits in a-buffer
cAccumBlueBits := 0; // Number of blue bits in a-buffer
cAccumAlphaBits := 0; // Number of alpha bits in a-buffer
cDepthBits := 16; // Specifies the depth of the depth buffer
cStencilBits := 0; // Turn off stencil buffer
cAuxBuffers := 0; // Not supported
iLayerType := PFD_MAIN_PLANE; // Ignored
bReserved := 0; // Number of overlay and underlay planes
dwLayerMask := 0; // Ignored
dwVisibleMask := 0; // Transparent color of underlay plane
dwDamageMask := 0; // Ignored
end;
// Attempts to find the pixel format supported by a device context that is the best match to a given pixel format specification.
PixelFormat := ChoosePixelFormat(h_DC, @pfd);
if (PixelFormat = 0) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to find a suitable pixel format', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Sets the specified device context's pixel format to the format specified by the PixelFormat.
if (not SetPixelFormat(h_DC, PixelFormat, @pfd)) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to set the pixel format', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Create a OpenGL rendering context
h_RC := wglCreateContext(h_DC);
if (h_RC = 0) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to create an OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Makes the specified OpenGL rendering context the calling thread's current rendering context
if (not wglMakeCurrent(h_DC, h_RC)) then
begin
glKillWnd(Fullscreen);
MessageBox(0, 'Unable to activate OpenGL rendering context', 'Error', MB_OK or MB_ICONERROR);
Result := False;
Exit;
end;
// Settings to ensure that the window is the topmost window
ShowWindow(h_Wnd, SW_SHOW);
SetForegroundWindow(h_Wnd);
SetFocus(h_Wnd);
// Ensure the OpenGL window is resized properly
glResizeWnd(Width, Height);
glInit();
Result := True;
end;
{--------------------------------------------------------------------}
{ Main message loop for the application }
{--------------------------------------------------------------------}
function WinMain(hInstance :HINST; hPrevInstance :HINST; lpCmdLine
Char; nCmdShow :Integer) :Integer; stdcall;var
msg : TMsg;
finished : Boolean;
begin
finished := False;
// Perform application initialization:
if not glCreateWnd(800, 600, false, 32) then
begin
Result := 0;
Exit;
end;
// Main message loop:
while not finished do
begin
if (PeekMessage(msg, 0, 0, 0, PM_REMOVE)) then // Check if there is a message for this window
begin
if (msg.message = WM_QUIT) // If WM_QUIT message received then we are done
then finished := True
else begin // Else translate and dispatch the message to this window
TranslateMessage(msg);
DispatchMessage(msg);
end;
end
else
begin
glDraw(GL_RENDER); // Draw the scene
SwapBuffers(h_DC); // Display the scene
if(keys[VK_ESCAPE])then finished := True; // If user pressed ESC then set finised TRUE
end;
end;
glKillWnd(FALSE);
Result := msg.wParam;
end;
begin
WinMain( hInstance, hPrevInst, CmdLine, CmdShow );
end.