LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   History :  
6
   05/04/11 - Yar - Added property FullScreenVideoMode (thanks to ltyrosine)
7
   08/12/10 - Yar - Added code for Lazarus (thanks Rustam Asmandiarov aka Predator)
8
   23/08/10 - Yar - Creation
9
   
10
}
11

12
unit GLSceneForm;
13

14
interface
15

16
{$I GLScene.inc}
17

18
uses
19
{$IFDEF GLS_DELPHI_OR_CPPB}
20
  Windows,
21
  Messages,
22
{$ELSE}
23
  LCLIntf,
24
  LCLType,
25
  LMessages,
26
  LCLVersion,
27
{$IF DEFINED(LCLwin32) or DEFINED(LCLwin64)}
28
  Windows, // need
29
  WSLCLClasses, Win32Int, Win32WSForms,
30
  Win32Proc, LCLMessageGlue, Win32WSControls,
31
{$IFEND}
32
{$ENDIF}
33
  Classes,
34
  Controls,
35
  Forms,
36
  GLScene,
37
  GLContext,
38
  GLCrossPlatform,
39
  GLScreen;
40

41
{$IFDEF GLS_DELPHI_OR_CPPB}
42
const
43
  lcl_major = 0;
44
  lcl_minor = 0;
45
  lcl_release = 0;
46
{$ENDIF}
47

48
type
49

50
  TGLSceneForm = class;
51

52
  // TGLFullScreenResolution
53
  //
54
  { Defines how GLSceneForm will handle fullscreen request
55
     fcWindowMaximize: Use current resolution (just maximize form and hide OS bars)
56
     fcNearestResolution: Change to nearest valid resolution from current window size
57
     fcManualResolution: Use FFullScreenVideoMode settings }
58
  TGLFullScreenResolution = (
59
    fcUseCurrent,
60
    fcNearestResolution,
61
    fcManualResolution);
62

63
  // TGLFullScreenVideoMode
64
  //
65
  { Screen mode settings }
66
  TGLFullScreenVideoMode = class(TPersistent)
67
  private
68
    FOwner: TGLSceneForm;
69
    FEnabled: Boolean;
70
    FAltTabSupportEnable: Boolean;
71
    FWidth: Integer;
72
    FHeight: Integer;
73
    FColorDepth: Integer;
74
    FFrequency: Integer;
75
    FResolutionMode: TGLFullScreenResolution;
76
    procedure SetEnabled(aValue: Boolean);
77
    procedure SetAltTabSupportEnable(aValue: Boolean);
78
  public
79
    constructor Create(AOwner: TGLSceneForm);
80
  published
81
    property Enabled: Boolean read FEnabled write SetEnabled default False;
82
    property AltTabSupportEnable: Boolean read FAltTabSupportEnable
83
      write SetAltTabSupportEnable default False;
84
    property ResolutionMode: TGLFullScreenResolution read FResolutionMode
85
      write FResolutionMode default fcUseCurrent;
86
    property Width: Integer read FWidth write FWidth;
87
    property Height: Integer read FHeight write FHeight;
88
    property ColorDepth: Integer read FColorDepth write FColorDepth;
89
    property Frequency: Integer read FFrequency write FFrequency;
90
  end;
91

92
  { TGLSceneForm }
93

94
  TGLSceneForm = class(TForm)
95
  private
96
     
97
    FBuffer: TGLSceneBuffer;
98
    FVSync: TVSyncMode;
99
    FOwnDC: HDC;
100
    FFullScreenVideoMode: TGLFullScreenVideoMode;
101
    procedure SetBeforeRender(const val: TNotifyEvent);
102
    function GetBeforeRender: TNotifyEvent;
103
    procedure SetPostRender(const val: TNotifyEvent);
104
    function GetPostRender: TNotifyEvent;
105
    procedure SetAfterRender(const val: TNotifyEvent);
106
    function GetAfterRender: TNotifyEvent;
107
    procedure SetCamera(const val: TGLCamera);
108
    function GetCamera: TGLCamera;
109
    procedure SetBuffer(const val: TGLSceneBuffer);
110

111
    function GetFieldOfView: single;
112
    procedure SetFieldOfView(const Value: single);
113
    function GetIsRenderingContextAvailable: Boolean;
114

115
    procedure LMEraseBkgnd(var Message: TLMEraseBkgnd); message LM_ERASEBKGND;
116
    procedure LMPaint(var Message: TLMPaint); message LM_PAINT;
117
    procedure LMSize(var Message: TLMSize); message LM_SIZE;
118
    procedure LMDestroy(var Message: TLMDestroy); message LM_DESTROY;
119
    procedure GetFocus(var Mess: TLMessage); message LM_ACTIVATE;
120
{$IF (lcl_major <= 0) and (lcl_minor <= 9) and (lcl_release < 31)}
121
    procedure LastFocus(var Mess: TLMessage); message LM_DEACTIVATE;
122
{$IFEND}
123

124
    procedure SetFullScreenVideoMode(AValue: TGLFullScreenVideoMode);
125
    procedure StartupFS;
126
    procedure ShutdownFS;
127
  protected
128
     
129
    procedure Notification(AComponent: TComponent; Operation: TOperation);
130
      override;
131
    procedure CreateWnd; override;
132
    procedure Loaded; override;
133

134
    procedure DoBeforeRender(Sender: TObject); dynamic;
135
    procedure DoBufferChange(Sender: TObject); virtual;
136
    procedure DoBufferStructuralChange(Sender: TObject); dynamic;
137

138
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
139
  public
140
    constructor Create(AOwner: TComponent); override;
141
    destructor Destroy; override;
142
    procedure DestroyWnd; override;
143

144
    property IsRenderingContextAvailable: Boolean read
145
      GetIsRenderingContextAvailable;
146
    property RenderDC: HDC read FOwnDC;
147
  published
148
     
149
    { Camera from which the scene is rendered. }
150
    property Camera: TGLCamera read GetCamera write SetCamera;
151

152
    { Specifies if the refresh should be synchronized with the VSync signal.
153
      If the underlying OpenGL ICD does not support the WGL_EXT_swap_control
154
      extension, this property is ignored. }
155
    property VSync: TVSyncMode read FVSync write FVSync default vsmNoSync;
156

157
    { Triggered before the scene's objects get rendered.
158
      You may use this event to execute your own OpenGL rendering. }
159
    property BeforeRender: TNotifyEvent read GetBeforeRender write
160
      SetBeforeRender;
161
    { Triggered just after all the scene's objects have been rendered.
162
      The OpenGL context is still active in this event, and you may use it
163
      to execute your own OpenGL rendering. }
164
    property PostRender: TNotifyEvent read GetPostRender write SetPostRender;
165
    { Called after rendering.
166
      You cannot issue OpenGL calls in this event, if you want to do your own
167
      OpenGL stuff, use the PostRender event. }
168
    property AfterRender: TNotifyEvent read GetAfterRender write SetAfterRender;
169

170
    { Access to buffer properties. }
171
    property Buffer: TGLSceneBuffer read FBuffer write SetBuffer;
172

173
    { Returns or sets the field of view for the viewer, in degrees.
174
      This value depends on the camera and the width and height of the scene.
175
      The value isn't persisted, if the width/height or camera.focallength is
176
      changed, FieldOfView is changed also. }
177
    property FieldOfView: single read GetFieldOfView write SetFieldOfView;
178

179
    property FullScreenVideoMode: TGLFullScreenVideoMode read
180
      FFullScreenVideoMode
181
      write SetFullScreenVideoMode;
182
  end;
183

184
  // Code created to workaround black screen and blinking when Manifest is enabled
185
  // Код создан для обхода черного экрана и мерцания при включенном Manifest'е
186
{$IF DEFINED(LCLwin32) or DEFINED(LCLwin64)}
187

188
  TGLSOpenGLForm = class(TWin32WSForm)
189
  published
190
    class function CreateHandle(const AWinControl: TWinControl; const AParams:
191
      TCreateParams): HWND; override;
192
  end;
193

194
procedure GLRegisterWSComponent(aControl: TComponentClass);
195
{$IFEND}
196

197

198
implementation
199

200
uses
201
  GLViewer;
202

203
constructor TGLSceneForm.Create(AOwner: TComponent);
204
begin
205
  FBuffer := TGLSceneBuffer.Create(Self);
206
  FVSync := vsmNoSync;
207
  FBuffer.ViewerBeforeRender := DoBeforeRender;
208
  FBuffer.OnChange := DoBufferChange;
209
  FBuffer.OnStructuralChange := DoBufferStructuralChange;
210
  FFullScreenVideoMode := TGLFullScreenVideoMode.Create(Self);
211
  inherited Create(AOwner);
212
end;
213

214
destructor TGLSceneForm.Destroy;
215
begin
216
  FBuffer.Free;
217
  FBuffer := nil;
218
  FFullScreenVideoMode.Destroy;
219
  inherited Destroy;
220
end;
221

222
// Notification
223
//
224

225
procedure TGLSceneForm.Notification(AComponent: TComponent; Operation:
226
  TOperation);
227
begin
228
  if (Operation = opRemove) and (FBuffer <> nil) then
229
  begin
230
    if (AComponent = FBuffer.Camera) then
231
      FBuffer.Camera := nil;
232
  end;
233
  inherited;
234
end;
235

236
// CreateWnd
237
//
238

239
procedure TGLSceneForm.CreateWnd;
240
begin
241
  inherited CreateWnd;
242
  // initialize and activate the OpenGL rendering context
243
  // need to do this only once per window creation as we have a private DC
244
  FBuffer.Resize(0, 0, Self.Width, Self.Height);
245
  FOwnDC := GetDC(Handle);
246
  FBuffer.CreateRC(FOwnDC, false);
247
end;
248

249
// DestroyWnd
250
//
251

252
procedure TGLSceneForm.DestroyWnd;
253
begin
254
  if Assigned(FBuffer) then
255
  begin
256
    FBuffer.DestroyRC;
257
    if FOwnDC <> 0 then
258
    begin
259
      ReleaseDC(Handle, FOwnDC);
260
      FOwnDC := 0;
261
    end;
262
  end;
263
  inherited;
264
end;
265

266
// Loaded
267
//
268

269
procedure TGLSceneForm.Loaded;
270
begin
271
  inherited Loaded;
272
  // initiate window creation
273
  HandleNeeded;
274
  if not (csDesigning in ComponentState) then
275
  begin
276
    if FFullScreenVideoMode.FEnabled then
277
      StartupFS;
278
  end;
279
end;
280

281
procedure TGLSceneForm.LMEraseBkgnd(var Message: TLMEraseBkgnd);
282
begin
283
  if IsRenderingContextAvailable then
284
    Message.Result := 1
285
  else
286
    inherited;
287
end;
288

289
procedure TGLSceneForm.LMPaint(var Message: TLMPaint);
290
var
291
  PS: TPaintStruct;
292
begin
293
  BeginPaint(Handle, PS);
294
  try
295
    if IsRenderingContextAvailable and (Width > 0) and (Height > 0) then
296
      FBuffer.Render;
297
  finally
298
    EndPaint(Handle, PS);
299
    Message.Result := 0;
300
  end;
301
end;
302

303
procedure TGLSceneForm.LMSize(var Message: TLMSize);
304
begin
305
  inherited;
306
  if Assigned(FBuffer) then
307
    FBuffer.Resize(0, 0, Message.Width, Message.Height);
308
end;
309

310
procedure TGLSceneForm.LMDestroy(var Message: TLMDestroy);
311
begin
312
  if Assigned(FBuffer) then
313
  begin
314
    FBuffer.DestroyRC;
315
    if FOwnDC <> 0 then
316
    begin
317
      ReleaseDC(Handle, FOwnDC);
318
      FOwnDC := 0;
319
    end;
320
  end;
321
  inherited;
322
end;
323

324
procedure TGLSceneForm.GetFocus(var Mess: TLMessage);
325
begin
326
  if not (csDesigning in ComponentState)
327
    and FFullScreenVideoMode.FEnabled
328
    and FFullScreenVideoMode.FAltTabSupportEnable then
329
    begin
330
      StartupFS;
331
    end;
332
  inherited;
333
end;
334

335
{$IF (lcl_major <= 0) and (lcl_minor <= 9) and (lcl_release < 31)}
336
procedure TGLSceneForm.LastFocus(var Mess: TLMessage);
337
begin
338
  if not (csDesigning in ComponentState)
339
    and FFullScreenVideoMode.FEnabled
340
    and FFullScreenVideoMode.FAltTabSupportEnable then
341
    begin
342
      ShutdownFS;
343
    end;
344
  inherited;
345
end;
346
{$IFEND}
347

348

349

350
procedure TGLFullScreenVideoMode.SetEnabled(aValue: Boolean);
351
begin
352
  if FEnabled <> aValue then
353
  begin
354
    FEnabled := aValue;
355
    if not ((csDesigning in FOwner.ComponentState)
356
      or (csLoading in FOwner.ComponentState)) then
357
    begin
358
      if FEnabled then
359
        FOwner.StartupFS
360
      else
361
        FOwner.ShutdownFS;
362
    end;
363
  end;
364
end;
365

366
constructor TGLFullScreenVideoMode.Create(AOwner: TGLSceneForm);
367
begin
368
  inherited Create;
369
  FOwner := AOwner;
370
  FEnabled := False;
371
  FAltTabSupportEnable := False;
372
  ReadVideoModes;
373
{$IFDEF MSWINDOWS}
374
  FWidth := vVideoModes[0].Width;
375
  FHeight := vVideoModes[0].Height;
376
  FColorDepth := vVideoModes[0].ColorDepth;
377
  FFrequency := vVideoModes[0].MaxFrequency;
378
{$ENDIF}
379
{$IFDEF GLS_X11_SUPPORT}
380
  FWidth := vVideoModes[0].vdisplay;
381
  FHeight := vVideoModes[0].hdisplay;
382
  FColorDepth := 32;
383
  FFrequency := 0;
384
{$ENDIF}
385
{$IFDEF DARWIN}
386
  FWidth := 1280;
387
  FHeight := 1024;
388
  FColorDepth := 32;
389
  FFrequency := 0;
390
  {$Message Hint 'Fullscreen mode not yet implemented for Darwin OSes' }
391
{$ENDIF}
392
  if FFrequency = 0 then
393
    FFrequency := 50;
394
  FResolutionMode := fcUseCurrent;
395
end;
396

397
procedure TGLFullScreenVideoMode.SetAltTabSupportEnable(aValue: Boolean);
398
begin
399
  if FAltTabSupportEnable <> aValue then
400
    FAltTabSupportEnable := aValue;
401
end;
402

403
procedure TGLSceneForm.StartupFS;
404
begin
405
  case FFullScreenVideoMode.FResolutionMode of
406
    fcNearestResolution:
407
      begin
408
        SetFullscreenMode(GetIndexFromResolution(ClientWidth, ClientHeight,
409
{$IFDEF MSWINDOWS}
410
        vVideoModes[0].ColorDepth));
411
{$ELSE}
412
        32));
413
{$ENDIF}
414
      end;
415
    fcManualResolution:
416
      begin
417
        SetFullscreenMode(GetIndexFromResolution(FFullScreenVideoMode.Width , FFullScreenVideoMode.Height, FFullScreenVideoMode.ColorDepth), FFullScreenVideoMode.Frequency);
418
      end;
419
  end;
420

421
  Left := 0;
422
  Top := 0;
423
  BorderStyle := bsNone;
424
  FormStyle := fsStayOnTop;
425
  BringToFront;
426
  WindowState := wsMaximized;
427

428
{$IFDEF FPC}
429
  ShowInTaskBar := stAlways;
430
{$ELSE}
431
{$IFDEF GLS_DELPHI_2009_UP}
432
  Application.MainFormOnTaskBar := True;
433
{$ENDIF}
434
{$ENDIF}
435
end;
436

437
procedure TGLSceneForm.ShutdownFS;
438
begin
439
  RestoreDefaultMode;
440
  SendToBack;
441
  WindowState := wsNormal;
442
  BorderStyle := bsSingle;
443
  FormStyle := fsNormal;
444
  Left := (Screen.Width div 2) - (Width div 2);
445
  Top := (Screen.Height div 2) - (Height div 2);
446
end;
447

448
// DoBeforeRender
449
//
450

451
procedure TGLSceneForm.DoBeforeRender(Sender: TObject);
452
begin
453
  SetupVSync(VSync);
454
end;
455

456
// DoBufferChange
457
//
458

459
procedure TGLSceneForm.DoBufferChange(Sender: TObject);
460
begin
461
  if (not Buffer.Rendering) and (not Buffer.Freezed) then
462
    Invalidate;
463
end;
464

465
// DoBufferStructuralChange
466
//
467

468
procedure TGLSceneForm.DoBufferStructuralChange(Sender: TObject);
469
begin
470
  DestroyWnd;
471
  CreateWnd;
472
end;
473

474
procedure TGLSceneForm.MouseMove(Shift: TShiftState; X, Y: Integer);
475
begin
476
  inherited;
477
  if csDesignInteractive in ControlStyle then
478
    FBuffer.NotifyMouseMove(Shift, X, Y);
479
end;
480

481
// SetBeforeRender
482
//
483

484
procedure TGLSceneForm.SetBeforeRender(const val: TNotifyEvent);
485
begin
486
  FBuffer.BeforeRender := val;
487
end;
488

489
// GetBeforeRender
490
//
491

492
function TGLSceneForm.GetBeforeRender: TNotifyEvent;
493
begin
494
  Result := FBuffer.BeforeRender;
495
end;
496

497
// SetPostRender
498
//
499

500
procedure TGLSceneForm.SetPostRender(const val: TNotifyEvent);
501
begin
502
  FBuffer.PostRender := val;
503
end;
504

505
// GetPostRender
506
//
507

508
function TGLSceneForm.GetPostRender: TNotifyEvent;
509
begin
510
  Result := FBuffer.PostRender;
511
end;
512

513
// SetAfterRender
514
//
515

516
procedure TGLSceneForm.SetAfterRender(const val: TNotifyEvent);
517
begin
518
  FBuffer.AfterRender := val;
519
end;
520

521
// GetAfterRender
522
//
523

524
function TGLSceneForm.GetAfterRender: TNotifyEvent;
525
begin
526
  Result := FBuffer.AfterRender;
527
end;
528

529
// SetCamera
530
//
531

532
procedure TGLSceneForm.SetCamera(const val: TGLCamera);
533
begin
534
  FBuffer.Camera := val;
535
end;
536

537
// GetCamera
538
//
539

540
function TGLSceneForm.GetCamera: TGLCamera;
541
begin
542
  Result := FBuffer.Camera;
543
end;
544

545
// SetBuffer
546
//
547

548
procedure TGLSceneForm.SetBuffer(const val: TGLSceneBuffer);
549
begin
550
  FBuffer.Assign(val);
551
end;
552

553
// GetFieldOfView
554
//
555

556
function TGLSceneForm.GetFieldOfView: single;
557
begin
558
  if not Assigned(Camera) then
559
    Result := 0
560
  else if Width < Height then
561
    Result := Camera.GetFieldOfView(Width)
562
  else
563
    Result := Camera.GetFieldOfView(Height);
564
end;
565

566
// SetFieldOfView
567
//
568

569
procedure TGLSceneForm.SetFieldOfView(const Value: single);
570
begin
571
  if Assigned(Camera) then
572
  begin
573
    if Width < Height then
574
      Camera.SetFieldOfView(Value, Width)
575
    else
576
      Camera.SetFieldOfView(Value, Height);
577
  end;
578
end;
579

580
procedure TGLSceneForm.SetFullScreenVideoMode(AValue: TGLFullScreenVideoMode);
581
begin
582
end;
583

584
// GetIsRenderingContextAvailable
585
//
586

587
function TGLSceneForm.GetIsRenderingContextAvailable: Boolean;
588
begin
589
  Result := FBuffer.RCInstantiated and FBuffer.RenderingContext.IsValid;
590
end;
591

592
{$IF DEFINED(LCLwin32) or DEFINED(LCLwin64)}
593
// FixBSod
594

595
function GlWindowProc(Window: HWND; Msg: UInt; wParam: Windows.wParam; LParam:
596
  Windows.LParam): LResult; stdcall;
597
var
598
  PaintMsg: TLMPaint;
599
  winctrl: TWinControl;
600
begin
601
  case Msg of
602
    WM_ERASEBKGND:
603
      begin
604
        Result := 0;
605
      end;
606
    WM_PAINT:
607
      begin
608
        winctrl := GetWin32WindowInfo(Window)^.WinControl;
609
        if Assigned(winctrl) then
610
        begin
611
          FillChar(PaintMsg, SizeOf(PaintMsg), 0);
612
          PaintMsg.Msg := LM_PAINT;
613
          PaintMsg.DC := wParam;
614
          DeliverMessage(winctrl, PaintMsg);
615
          Result := PaintMsg.Result;
616
        end
617
        else
618
          Result := WindowProc(Window, Msg, wParam, LParam);
619
      end;
620
  else
621
    Result := WindowProc(Window, Msg, wParam, LParam);
622
  end;
623
end;
624

625
{$IFEND}
626

627
function GetDesigningBorderStyle(const AForm: TCustomForm): TFormBorderStyle;
628
begin
629
  if csDesigning in AForm.ComponentState then
630
    Result := bsSizeable
631
  else
632
    Result := AForm.BorderStyle;
633
end;
634

635
function CalcBorderIconsFlags(const AForm: TCustomForm): DWORD;
636
var
637
  BorderIcons: TBorderIcons;
638
begin
639
  Result := 0;
640
  BorderIcons := AForm.BorderIcons;
641
  if (biSystemMenu in BorderIcons) or (csDesigning in AForm.ComponentState) then
642
    Result := Result or WS_SYSMENU;
643

644
  if GetDesigningBorderStyle(AForm) in [bsNone, bsSingle, bsSizeable] then
645
  begin
646
    if biMinimize in BorderIcons then
647
      Result := Result or WS_MINIMIZEBOX;
648
    if biMaximize in BorderIcons then
649
      Result := Result or WS_MAXIMIZEBOX;
650
  end;
651
end;
652

653
function CalcBorderIconsFlagsEx(const AForm: TCustomForm): DWORD;
654
var
655
  BorderIcons: TBorderIcons;
656
begin
657
  Result := 0;
658
  BorderIcons := AForm.BorderIcons;
659
  if GetDesigningBorderStyle(AForm) in [bsSingle, bsSizeable, bsDialog] then
660
  begin
661
    if biHelp in BorderIcons then
662
      Result := Result or WS_EX_CONTEXTHELP;
663
  end;
664
end;
665

666
function CalcBorderStyleFlags(const AForm: TCustomForm): DWORD;
667
begin
668
  Result := WS_CLIPCHILDREN or WS_CLIPSIBLINGS;
669
  case GetDesigningBorderStyle(AForm) of
670
    bsSizeable, bsSizeToolWin:
671
      Result := Result or (WS_OVERLAPPED or WS_THICKFRAME or WS_CAPTION);
672
    bsSingle, bsToolWindow:
673
      Result := Result or (WS_OVERLAPPED or WS_BORDER or WS_CAPTION);
674
    bsDialog:
675
      Result := Result or (WS_POPUP or WS_BORDER or WS_CAPTION);
676
    bsNone:
677
      if (AForm.Parent = nil) and (AForm.ParentWindow = 0) then
678
        Result := Result or WS_POPUP;
679
  end;
680
end;
681

682
function CalcBorderStyleFlagsEx(const AForm: TCustomForm): DWORD;
683
begin
684
  Result := 0;
685
  case GetDesigningBorderStyle(AForm) of
686
    bsDialog:
687
      Result := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
688
    bsToolWindow, bsSizeToolWin:
689
      Result := WS_EX_TOOLWINDOW;
690
  end;
691
end;
692

693
procedure CalcFormWindowFlags(const AForm: TCustomForm; var Flags, FlagsEx:
694
  DWORD);
695
begin
696
  Flags := CalcBorderStyleFlags(AForm);
697
  if AForm.Parent <> nil then
698
    Flags := (Flags or WS_CHILD) and not WS_POPUP;
699
  // clear border style flags
700
  FlagsEx := FlagsEx and not (WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE or
701
    WS_EX_TOOLWINDOW);
702
  // set border style flags
703
  FlagsEx := FlagsEx or CalcBorderStyleFlagsEx(AForm);
704
  if (AForm.FormStyle in fsAllStayOnTop) and not (csDesigning in
705
    AForm.ComponentState) then
706
    FlagsEx := FlagsEx or WS_EX_TOPMOST;
707
  Flags := Flags or CalcBorderIconsFlags(AForm);
708
  FlagsEx := FlagsEx or CalcBorderIconsFlagsEx(AForm);
709
end;
710

711
procedure AdjustFormBounds(const AForm: TCustomForm; var SizeRect: TRect);
712
begin
713
  // the LCL defines the size of a form without border, win32 with.
714
  // -> adjust size according to BorderStyle
715
  SizeRect := AForm.BoundsRect;
716
  AdjustWindowRectEx(SizeRect, CalcBorderStyleFlags(AForm),
717
    false, CalcBorderStyleFlagsEx(AForm));
718
end;
719

720
{$IF DEFINED(LCLwin32) or DEFINED(LCLwin64)}
721
class function TGLSOpenGLForm.CreateHandle(const AWinControl: TWinControl; const
722
  AParams: TCreateParams): HWND;
723
var
724
  Params: TCreateWindowExParams;
725
  lForm: TCustomForm absolute AWinControl;
726
  Bounds: TRect;
727
  SystemMenu: HMenu;
728
begin
729
  // general initialization of Params
730
{$IF (lcl_major = 0) and (lcl_release <= 28) }
731
  PrepareCreateWindow(AWinControl, Params);
732
{$ELSE}
733
  PrepareCreateWindow(AWinControl, AParams, Params);
734
{$IFEND}
735
  // customization of Params
736
  with Params do
737
  begin
738
    CalcFormWindowFlags(lForm, Flags, FlagsEx);
739
    pClassName := @ClsName;
740
    WindowTitle := StrCaption;
741
    AdjustFormBounds(lForm, Bounds);
742
    if (lForm.Position in [poDefault, poDefaultPosOnly]) and not (csDesigning in
743
      lForm.ComponentState) then
744
    begin
745
      Left := CW_USEDEFAULT;
746
      Top := CW_USEDEFAULT;
747
    end
748
    else
749
    begin
750
      Left := Bounds.Left;
751
      Top := Bounds.Top;
752
    end;
753
    if (lForm.Position in [poDefault, poDefaultSizeOnly]) and not (csDesigning in
754
      lForm.ComponentState) then
755
    begin
756
      Width := CW_USEDEFAULT;
757
      Height := CW_USEDEFAULT;
758
    end
759
    else
760
    begin
761
      Width := Bounds.Right - Bounds.Left;
762
      Height := Bounds.Bottom - Bounds.Top;
763
    end;
764
    SubClassWndProc := @GlWindowProc;
765
    if not (csDesigning in lForm.ComponentState) and lForm.AlphaBlend then
766
      FlagsEx := FlagsEx or WS_EX_LAYERED;
767
  end;
768
  SetStdBiDiModeParams(AWinControl, Params);
769
  // create window
770
  FinishCreateWindow(AWinControl, Params, false);
771
  Result := Params.Window;
772

773
  // remove system menu items for bsDialog
774
  if (lForm.BorderStyle = bsDialog) and not (csDesigning in lForm.ComponentState)
775
    then
776
  begin
777
    SystemMenu := GetSystemMenu(Result, false);
778
    DeleteMenu(SystemMenu, SC_RESTORE, MF_BYCOMMAND);
779
    DeleteMenu(SystemMenu, SC_SIZE, MF_BYCOMMAND);
780
    DeleteMenu(SystemMenu, SC_MINIMIZE, MF_BYCOMMAND);
781
    DeleteMenu(SystemMenu, SC_MAXIMIZE, MF_BYCOMMAND);
782
    DeleteMenu(SystemMenu, 1, MF_BYPOSITION);
783
      // remove the separator between move and close
784
  end;
785

786
  // Beginning with Windows 2000 the UI in an application may hide focus
787
  // rectangles and accelerator key indication. According to msdn we need to
788
  // initialize all root windows with this message
789
  if WindowsVersion >= wv2000 then
790
    Windows.SendMessage(Result, WM_CHANGEUISTATE, MakeWParam(UIS_INITIALIZE,
791
      UISF_HIDEFOCUS or UISF_HIDEACCEL), 0)
792
end;
793

794
procedure GLRegisterWSComponent(aControl: TComponentClass);
795
begin
796
  RegisterWSComponent(aControl, TGLSOpenGLForm);
797
end;
798
{$endif}
799

800
// ------------------------------------------------------------------
801
// ------------------------------------------------------------------
802
// ------------------------------------------------------------------
803
initialization
804

805
  // ------------------------------------------------------------------
806
  // ------------------------------------------------------------------
807
  // ------------------------------------------------------------------
808

809
  RegisterClass(TGLSceneForm);
810

811
{$IF DEFINED(LCLwin32) or DEFINED(LCLwin64)}
812
  // Code created to workaround black screen and blinking when Manifest is enabled
813
  // You may comment it for Win2000\98
814
  // Код создан для обхода черного экрана и мерцания при включенном Manifest'е
815
  // Можно закоментировать для Win2000\98
816
  GLRegisterWSComponent(TGLSceneForm);
817
{$IFEND}
818

819

820
end.
821