- unit HAL1_GRAPHICS_glFormTemplate;
- interface
- {$REGION 'uses 1.1'}
- uses
- ADODB, Classes, Contnrs, Controls, DateUtils, Dialogs, DB, ComCtrls, ExtCtrls,
- Forms, Graphics, Menus, Messages, StdCtrls, SysUtils,
- Types, Variants, Windows
- , dglOpenGL
- , ...
- ;
- {$ENDREGION}
- type
- TglForm_Template = class(TForm)
- private
- FDC: HDC;
- FRC: HGLRC;
- FParentComponent: TWinControl;
- FblActive: Boolean;
- Raster: TGLObjectTile;
- clglObjects: TComponentList;
- timRenderTimer: TTimer;
- procedure DoRenderTimer(Sender: TObject);
- procedure SetActive(_Active: Boolean);
- protected
- procedure RenderEmptyBackground;
- public
- Debug: Boolean;
- Background_RenderRaster: Boolean;
- Background_Color: TColor;
- TextSuiteManager: TglTextSuiteManager;
- procedure Render;
- property DC: HDC read FDC;
- property RC: HGLRC read FRC;
- property Active: Boolean read FblActive write SetActive;
- property Parent: TWinControl read FParentComponent write SetParent;
- function AddglObject(_glObject: TGLObject): Boolean;
- function RemoveglObject(_glObject: TGLObject): Boolean;
- procedure SetMyParentComponent(_Parent: TWinControl);
- constructor Create(_Owner: TComponent); overload; override;
- destructor Destroy; override;
- end;
- implementation
- {$I 'compileoptions.inc'}
- {$WARN UNIT_PLATFORM OFF}
- {$WARN SYMBOL_PLATFORM OFF}
- { TglForm_Template }
- function TglForm_Template.AddglObject(_glObject: TGLObject): Boolean;
- begin
- Result := False;
- if not assigned(_glObject) then Exit;
- if not _glObject.InheritsFrom(TGLObject) then Exit;
- if clglObjects.IndexOf(_glObject) < 0 then begin
- TGLObject(_glObject).DC := Self.DC;
- TGLObject(_glObject).RC := Self.RC;
- TGLObject(_glObject).TextSuiteManager := Self.TextSuiteManager;
- clglObjects.Add(_glObject);
- end;
- Result := (clglObjects.IndexOf(_glObject) > -1);
- end;
- constructor TglForm_Template.Create(_Owner: TComponent);
- begin
- try
- inherited CreateNew(_Owner);
- Debug := False;
- {$Region 'OpenGL initialisieren'}
- try
- FblActive := False;
- FParentComponent := NIL;
- clglObjects := TComponentList.Create(False);
- FDC := GetDC(Handle);
- if not InitOpenGL then begin
- MessageBox(_('OpenGL konnte nicht initialisiert werden. Anwendung wird beendet!'), MB_ICONERROR + MB_OK);
- Application.Terminate;
- end;
- FRC:= CreateRenderingContext( DC,
- [opDoubleBuffered],
- 32,
- 24,
- 0,0,0,
- 0);
- ActivateRenderingContext(DC, RC);
- ReadExtensions;
- ReadImplementationProperties;
- Visible := True;
- OnResize := Self.DoRenderTimer;
- except
- on E: SysUtils.Exception do begin
- Log('TglForm_Template.Create.2', M, E.Message, ws_SEVERITY_EXCEPTION);
- end;
- end;
- {$EndRegion}
- // Hintergrundraster erstellen
- Raster := TGLObjectTile.Create(Self);
- with Raster do begin
- Raster.DC := Self.DC;
- Left := 0;
- Top := 0;
- end;
- timRenderTimer := TTimer.Create(Self);
- with timRenderTimer do begin
- Enabled := False;
- Interval := 1000 div 120;
- OnTimer := DoRenderTimer;
- end;
- Active := True;
- Background_RenderRaster := True;
- Background_Color := $00660000;
- TextSuiteManager := TglTextSuiteManager.Create(Self);
- except
- on E: SysUtils.Exception do begin
- Log('TglForm_Template.Create.1', M, E.Message, ws_SEVERITY_EXCEPTION);
- end;
- end;
- end;
- destructor TglForm_Template.Destroy;
- begin
- Active := False;
- FreeAndNil(TextSuiteManager);
- FreeAndNil(clglObjects);
- FreeAndNil(Raster);
- try
- try
- // Renderkontext deaktiveren
- DeactivateRenderingContext;
- // Renderkontext "befreien"
- wglDeleteContext(RC);
- // Erhaltenen Gerätekontext auch wieder freigeben
- ReleaseDC(Handle, DC);
- except
- end;
- finally
- inherited;
- end;
- end;
- function TglForm_Template.RemoveglObject(_glObject: TGLObject): Boolean;
- begin
- Result := False;
- try
- _glObject.TextSuiteManager := NIL;
- clglObjects.Remove(_glObject);
- Result := (clglObjects.IndexOf(_glObject) < 0);
- except end;
- end;
- procedure TglForm_Template.Render;
- var
- i: integer;
- glObject: TGLObject;
- begin
- RenderEmptyBackground;
- if Background_RenderRaster then begin
- Raster.PositionUserDesigned.Width := Self.ClientWidth;
- Raster.PositionUserDesigned.Height := Self.ClientHeight;
- Raster.Render;
- end;
- for i := 0 to clglObjects.Count - 1 do begin
- glObject := TGLObject(clglObjects.Items[i]);
- if glObject.DC <> Self.DC then begin
- glObject.DC := Self.DC;
- end;
- if glObject.RC <> Self.RC then begin
- glObject.RC := Self.RC;
- end;
- glObject.Render;
- end;
- SwapBuffers(DC);
- end;
- procedure TglForm_Template.RenderEmptyBackground;
- var
- r, g, b: Byte;
- begin
- ActivateRenderingContext(DC, RC);
- HAL_Color2RGB(Background_Color, r, g, b);
- glClearColor(r/255, g/255, b/255, 1);
- glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT);
- glViewport(0, 0, ClientWidth, ClientHeight);
- glMatrixMode(GL_PROJECTION);
- glLoadIdentity();
- glOrtho(0, ClientWidth, ClientHeight, 0, 0, 1000);
- glMatrixMode(GL_MODELVIEW);
- glLoadIdentity;
- glEnable(GL_ALPHA_TEST);
- glEnable(GL_CULL_FACE);
- glCullFace(GL_BACK);
- end;
- procedure TglForm_Template.SetActive(_Active: Boolean);
- begin
- FblActive := _Active;
- timRenderTimer.Enabled := _Active;
- end;
- procedure TglForm_Template.SetMyParentComponent(_Parent: TWinControl);
- begin
- try
- FParentComponent := _Parent;
- if assigned(_Parent) then begin
- Windows.SetParent(Self.Handle, _Parent.Handle);
- BorderStyle := bsNone;
- BoundsRect := Rect(0, 0, _Parent.ClientWidth, _Parent.ClientHeight);
- end else begin
- Windows.SetParent(Self.Handle, 0);
- BorderStyle := bsSizeable;
- end;
- except
- on E: SysUtils.Exception do begin
- Log('TglForm_Template.SetMyParentComponent', M, E.Message, ws_SEVERITY_EXCEPTION);
- end;
- end;
- end;
- procedure TglForm_Template.DoRenderTimer(Sender: TObject);
- begin
- timRenderTimer.Enabled := False;
- Render;
- timRenderTimer.Enabled := True;
- end;
- end.