paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-19 04:19:09 +02:00
Code Issues Packages Projects Releases Wiki Activity

added OnMakeCurrent

Browse Source 
git-svn-id: trunk@5291 -
This commit is contained in:
mattias 2004-03-10 23:06:37 +00:00
parent ec1a73dded
commit 0b9b115c89
1 changed files with 21 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
components/gtk/gtkglarea/gtkglareacontrol.pas
View File

@ -25,11 +25,15 @@ uses
GLib, NVGL, GTKGLArea_Int;
type
TGtkGlAreaMakeCurrentEvent = procedure(Sender: TObject;
var Allow: boolean) of object;
{ TCustomGTKGLAreaControl }
TCustomGTKGLAreaControl = class(TWinControl)
private
FCanvas: TCanvas; // only valid at designtime
FOnMakeCurrent: TGtkGlAreaMakeCurrentEvent;
FOnPaint: TNotifyEvent;
FCurrentFrameTime: integer; // in msec
FLastFrameTime: integer; // in msec
@ -46,11 +50,13 @@ type
procedure DoOnResize; override;
procedure DoOnPaint; virtual;
procedure SwapBuffers; virtual;
procedure MakeCurrent; virtual;
function MakeCurrent: integer; virtual;
public
property Widget: PGtkGLArea read GetWidget;
property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
property FrameDiffTimeInMSecs: integer read FFrameDiffTime;
property OnMakeCurrent: TGtkGlAreaMakeCurrentEvent read FOnMakeCurrent
write FOnMakeCurrent;
end;
@ -131,7 +137,7 @@ procedure TCustomGTKGLAreaControl.Paint;
begin
if (not (csDesigning in ComponentState))
and Enabled and Visible and HandleAllocated
and (gint(True) = gtk_gl_area_make_current(Widget)) then begin
and (gint(True) = MakeCurrent) then begin
UpdateFrameTimeDiff;
DoOnPaint;
end;
@ -141,7 +147,7 @@ procedure TCustomGTKGLAreaControl.DoOnResize;
begin
if (not (csDesigning in ComponentState))
and Enabled and Visible and HandleAllocated
and (gint(True) = gtk_gl_area_make_current(Widget)) then
and (gint(True) = MakeCurrent) then
glViewport (0, 0, Width, Height);
inherited DoOnResize;
end;
@ -156,9 +162,19 @@ begin
gtk_gl_area_swap_buffers(Widget);
end;
procedure TCustomGTKGLAreaControl.MakeCurrent;
function TCustomGTKGLAreaControl.MakeCurrent: integer;
var
Allowed: Boolean;
begin
gtk_gl_area_make_current(Widget);
if Assigned(FOnMakeCurrent) then begin
Allowed:=true;
OnMakeCurrent(Self,Allowed);
if not Allowed then begin
Result:=gint(False);
exit;
end;
end;
Result:=gtk_gl_area_make_current(Widget);
end;
procedure TCustomGTKGLAreaControl.WMPaint(var Message: TLMPaint);