LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
  Component to make it easy to record GLScene frames into an AVI file
6

7
   History :  
8
   17/11/14 - PW - Refactored TAVIRecorder to TGLAVIRecorder
9
   12/07/07 - DaStr - Improved Cross-Platform compatibility
10
  (Bugtracker ID = 1684432)
11
   17/03/07 - DaStr - Dropped Kylix support in favor of FPC (BugTracekrID=1681585)
12
   29/01/07 - DaStr - Moved registration to GLSceneRegister.pas
13
   01/06/05 - NelC - Replaced property GLFullScreenViewer with GLNonVisualViewer
14
   26/01/05 - JAJ - Can now operate with a GLFullScreenViewer
15
   22/10/04 - EG - Can now operate without a SceneViewer
16
   13/05/04 - EG - Added irmBitBlt mode (now the default mode)
17
   05/01/04 - EG - Added Recording function and ability to record arbitrary bitmap,
18
  Added OnPostProcessEvent
19
   08/07/03 - NelC - Fixed access violation on exit (thx Solerman Kaplon)
20
  and minor updates
21
   11/12/01 - EG - Minor changes for compatibility with JEDI VfW.pas
22
  <li<02/03/01 - EG - Added TAVIImageRetrievalMode
23
   24/02/01 - NelC - Creation and initial code
24
   
25
}
26
unit GLAVIRecorder;
27

28
interface
29

30
{$I GLScene.inc}
31
{$IFNDEF MSWINDOWS}{$MESSAGE Error 'Unit not supported'}{$ENDIF}
32

33
uses
34
  Windows,
35
  Messages, Classes, SysUtils,
36
  Controls, Forms, Extctrls, Graphics, Dialogs,
37
  GLGraphics, GLSVfw, GLScene, GLViewer;
38

39
type
40
  TAVICompressor = (acDefault, acShowDialog, acDivX);
41

42
  PAVIStream = ^IAVIStream;
43

44
  // TAVISizeRestriction
45
  //
46
  { Frame size restriction.
47
    Forces frame dimensions to be a multiple of 2, 4, or 8. Some compressors
48
    require this. e.g. DivX 5.2.1 requires mutiples of 2. }
49
  TAVISizeRestriction = (srNoRestriction, srForceBlock2x2, srForceBlock4x4,
50
    srForceBlock8x8);
51

52
  TAVIRecorderState = (rsNone, rsRecording);
53

54
  // TAVIImageRetrievalMode
55
  //
56
  { Image retrieval mode for frame capture.
57
    Following modes are supported:
58
     irmSnapShot : retrieve OpenGL framebuffer content using glReadPixels
59
     irmRenderToBitmap : renders the whole scene to a bitmap, this is
60
    the slowest mode, but it won't be affected by driver-side specifics.
61
     irmBitBlt : tranfers the framebuffer using the BitBlt function,
62
    usually the fastest solution
63
      }
64
  TAVIImageRetrievalMode = (irmSnapShot, irmRenderToBitmap, irmBitBlt);
65

66
  TAVIRecorderPostProcessEvent = procedure(Sender: TObject; frame: TBitmap)
67
    of object;
68

69
  // TGLAVIRecorder
70
  //
71
  { Component to make it easy to record GLScene frames into an AVI file. }
72
  TGLAVIRecorder = class(TComponent)
73
  private
74
     
75
    AVIBitmap: TBitmap;
76
    AVIFrameIndex: integer;
77

78
    AVI_DPI: integer;
79

80
    asi: TAVIStreamInfo;
81

82
    pfile: IAVIFile;
83
    Stream, Stream_c: IAVIStream; // AVI stream and stream to be compressed
84

85
    FBitmapInfo: PBitmapInfoHeader;
86
    FBitmapBits: Pointer;
87
    FBitmapSize: Dword;
88

89
    FTempName: String;
90
    // so that we know the filename to delete case of user abort
91

92
    FAVIFilename: string;
93
    FFPS: byte;
94
    FWidth: integer;
95
    FHeight: integer;
96
    FSizeRestriction: TAVISizeRestriction;
97
    FImageRetrievalMode: TAVIImageRetrievalMode;
98
    RecorderState: TAVIRecorderState;
99
    FOnPostProcessEvent: TAVIRecorderPostProcessEvent;
100

101
    FBuffer: TGLSceneBuffer;
102

103
    procedure SetHeight(const val: integer);
104
    procedure SetWidth(const val: integer);
105
    procedure SetSizeRestriction(const val: TAVISizeRestriction);
106
    procedure SetGLSceneViewer(const Value: TGLSceneViewer);
107
    procedure SetGLNonVisualViewer(const Value: TGLNonVisualViewer);
108

109
  protected
110
     
111
    // Now, TAVIRecorder is tailored for GLScene. Maybe we should make a generic
112
    // TAVIRecorder, and then sub-class it to use with GLScene
113
    FGLSceneViewer: TGLSceneViewer;
114
    // FGLNonVisualViewer accepts GLNonVisualViewer and GLFullScreenViewer
115
    FGLNonVisualViewer: TGLNonVisualViewer;
116
    // FCompressor determines if the user is to choose a compressor via a dialog box, or
117
    // just use a default compressor without showing a dialog box.
118
    FCompressor: TAVICompressor;
119
    // some video compressor assumes input dimensions to be multiple of 2, 4 or 8.
120
    // Restricted() is for rounding off the width and height.
121
    // Currently I can't find a simple way to know which compressor imposes
122
    // what resiction, so the SizeRestiction property is there for the user to set.
123
    // The source code of VirtualDub (http://www.virtualdub.org/)
124
    // may give us some cues on this.
125
    // ( BTW, VirtualDub is an excellent freeware for editing your AVI. For
126
    // converting AVI into MPG, try AVI2MPG1 - http://www.mnsi.net/~jschlic1 )
127
    function Restricted(s: integer): integer;
128

129
    procedure InternalAddAVIFrame;
130

131
  public
132
     
133
    constructor Create(AOwner: TComponent); override;
134
    destructor Destroy; override;
135

136
    function CreateAVIFile(DPI: integer = 0): boolean;
137
    procedure AddAVIFrame; overload;
138
    procedure AddAVIFrame(bmp: TBitmap); overload;
139
    procedure CloseAVIFile(UserAbort: boolean = false);
140
    function Recording: boolean;
141

142
  published
143
     
144
    property FPS: byte read FFPS write FFPS default 25;
145
    property GLSceneViewer: TGLSceneViewer read FGLSceneViewer
146
      write SetGLSceneViewer;
147
    property GLNonVisualViewer: TGLNonVisualViewer read FGLNonVisualViewer
148
      write SetGLNonVisualViewer;
149
    property Width: integer read FWidth write SetWidth;
150
    property Height: integer read FHeight write SetHeight;
151
    property Filename: String read FAVIFilename write FAVIFilename;
152
    property Compressor: TAVICompressor read FCompressor write FCompressor
153
      default acDefault;
154
    property SizeRestriction: TAVISizeRestriction read FSizeRestriction
155
      write SetSizeRestriction default srForceBlock8x8;
156
    property ImageRetrievalMode: TAVIImageRetrievalMode read FImageRetrievalMode
157
      write FImageRetrievalMode default irmBitBlt;
158

159
    property OnPostProcessEvent: TAVIRecorderPostProcessEvent
160
      read FOnPostProcessEvent write FOnPostProcessEvent;
161

162
  end;
163

164
  // ---------------------------------------------------------------------
165
  // ---------------------------------------------------------------------
166
  // ---------------------------------------------------------------------
167
implementation
168

169
// ---------------------------------------------------------------------
170
// ---------------------------------------------------------------------
171
// ---------------------------------------------------------------------
172

173
// DIB support rountines for AVI output
174

175
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP;
176
  var BI: TBitmapInfoHeader);
177
var
178
  BM: Windows.TBitmap;
179
begin
180
  GetObject(Bitmap, SizeOf(BM), @BM);
181
  with BI do
182
  begin
183
    biSize := SizeOf(BI);
184
    biWidth := BM.bmWidth;
185
    biHeight := BM.bmHeight;
186
    biPlanes := 1;
187
    biXPelsPerMeter := 0;
188
    biYPelsPerMeter := 0;
189
    biClrUsed := 0;
190
    biClrImportant := 0;
191
    biCompression := BI_RGB;
192
    biBitCount := 24;
193
    // force 24 bits. Most video compressors would deal with 24-bit frames only.
194
    biSizeImage := (((biWidth * biBitCount) + 31) div 32) * 4 * biHeight;
195
  end;
196
end;
197

198
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: integer;
199
  var ImageSize: Dword);
200
var
201
  BI: TBitmapInfoHeader;
202
begin
203
  InitializeBitmapInfoHeader(Bitmap, BI);
204
  InfoHeaderSize := SizeOf(TBitmapInfoHeader);
205
  ImageSize := BI.biSizeImage;
206
end;
207

208
// InternalGetDIB
209
//
210
function InternalGetDIB(Bitmap: HBITMAP; var bitmapInfo; var bits): boolean;
211
var
212
  focus: HWND;
213
  dc: HDC;
214
  errCode: integer;
215
begin
216
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(bitmapInfo));
217
  focus := GetFocus;
218
  dc := GetDC(focus);
219
  try
220
    errCode := GetDIBits(dc, Bitmap, 0, TBitmapInfoHeader(bitmapInfo).biHeight,
221
      @bits, TBitmapInfo(bitmapInfo), DIB_RGB_COLORS);
222
    Result := (errCode <> 0);
223
  finally
224
    ReleaseDC(focus, dc);
225
  end;
226
end;
227

228
// ------------------
229
// ------------------ TAVIRecorder ------------------
230
// ------------------
231

232
// Create
233
//
234
constructor TGLAVIRecorder.Create(AOwner: TComponent);
235
begin
236
  inherited;
237
  FWidth := 320; // default values
238
  FHeight := 200;
239
  FFPS := 25;
240
  FCompressor := acDefault;
241
  RecorderState := rsNone;
242
  FSizeRestriction := srForceBlock8x8;
243
  FImageRetrievalMode := irmBitBlt;
244
end;
245

246
// Destroy
247
//
248
destructor TGLAVIRecorder.Destroy;
249
begin
250
  // if still open here, abort it
251
  if RecorderState = rsRecording then
252
    CloseAVIFile(True);
253
  inherited;
254
end;
255

256
// Restricted
257
//
258
function TGLAVIRecorder.Restricted(s: integer): integer;
259
begin
260
  case FSizeRestriction of
261
    srForceBlock2x2:
262
      Result := (s div 2) * 2;
263
    srForceBlock4x4:
264
      Result := (s div 4) * 4;
265
    srForceBlock8x8:
266
      Result := (s div 8) * 8;
267
  else
268
    Result := s;
269
  end;
270
end;
271

272
// SetHeight
273
//
274
procedure TGLAVIRecorder.SetHeight(const val: integer);
275
begin
276
  if (RecorderState <> rsRecording) and (val <> FHeight) and (val > 0) then
277
    FHeight := Restricted(val);
278
end;
279

280
// SetWidth
281
//
282
procedure TGLAVIRecorder.SetWidth(const val: integer);
283
begin
284
  if (RecorderState <> rsRecording) and (val <> FWidth) and (val > 0) then
285
    FWidth := Restricted(val);
286
end;
287

288
// SetSizeRestriction
289
//
290
procedure TGLAVIRecorder.SetSizeRestriction(const val: TAVISizeRestriction);
291
begin
292
  if val <> FSizeRestriction then
293
  begin
294
    FSizeRestriction := val;
295
    FHeight := Restricted(FHeight);
296
    FWidth := Restricted(FWidth);
297
  end;
298
end;
299

300
// AddAVIFrame (from sceneviewer)
301
//
302
procedure TGLAVIRecorder.AddAVIFrame;
303
var
304
  bmp32: TGLBitmap32;
305
  bmp: TBitmap;
306
begin
307
  if RecorderState <> rsRecording then
308
    raise Exception.Create('Cannot add frame to AVI. AVI file not created.');
309

310
  if FBuffer <> nil then
311
    case ImageRetrievalMode of
312
      irmSnapShot:
313
        begin
314
          bmp32 := FBuffer.CreateSnapShot;
315
          try
316
            bmp := bmp32.Create32BitsBitmap;
317
            try
318
              AVIBitmap.Canvas.Draw(0, 0, bmp);
319
            finally
320
              bmp.Free;
321
            end;
322
          finally
323
            bmp32.Free;
324
          end;
325
        end;
326
      irmBitBlt:
327
        begin
328
          FBuffer.RenderingContext.Activate;
329
          try
330
            BitBlt(AVIBitmap.Canvas.Handle, 0, 0, AVIBitmap.Width,
331
              AVIBitmap.Height, wglGetCurrentDC, 0, 0, SRCCOPY);
332
          finally
333
            FBuffer.RenderingContext.Deactivate;
334
          end;
335
        end;
336
      irmRenderToBitmap:
337
        begin
338
          FBuffer.RenderToBitmap(AVIBitmap, AVI_DPI);
339
        end;
340
    else
341
      Assert(false);
342
    end;
343

344
  InternalAddAVIFrame;
345
end;
346

347
// AddAVIFrame (from custom bitmap)
348
//
349
procedure TGLAVIRecorder.AddAVIFrame(bmp: TBitmap);
350
begin
351
  if RecorderState <> rsRecording then
352
    raise Exception.Create('Cannot add frame to AVI. AVI file not created.');
353
  AVIBitmap.Canvas.Draw(0, 0, bmp);
354

355
  InternalAddAVIFrame;
356
end;
357

358
// InternalAddAVIFrame
359
//
360
procedure TGLAVIRecorder.InternalAddAVIFrame;
361
begin
362
  if Assigned(FOnPostProcessEvent) then
363
    FOnPostProcessEvent(Self, AVIBitmap);
364
  with AVIBitmap do
365
  begin
366
    InternalGetDIB(Handle, FBitmapInfo^, FBitmapBits^);
367
    if AVIStreamWrite(Stream_c, AVIFrameIndex, 1, FBitmapBits, FBitmapSize,
368
      AVIIF_KEYFRAME, nil, nil) <> AVIERR_OK then
369
      raise Exception.Create('Add Frame Error');
370
    Inc(AVIFrameIndex);
371
  end;
372
end;
373

374
function TGLAVIRecorder.CreateAVIFile(DPI: integer = 0): boolean;
375
var
376
  SaveDialog: TSaveDialog;
377
  gaAVIOptions: TAVICOMPRESSOPTIONS;
378
  galpAVIOptions: PAVICOMPRESSOPTIONS;
379
  bitmapInfoSize: integer;
380
  AVIResult: Cardinal;
381
  ResultString: String;
382
begin
383
  FTempName := FAVIFilename;
384

385
  if FTempName = '' then
386
  begin
387
    // if user didn't supply a filename, then ask for it
388
    SaveDialog := TSaveDialog.Create(Application);
389
    try
390
      with SaveDialog do
391
      begin
392
        Options := [ofHideReadOnly, ofNoReadOnlyReturn];
393
        DefaultExt := '.avi';
394
        Filter := 'AVI Files (*.avi)|*.avi';
395
        if Execute then
396
          FTempName := SaveDialog.Filename;
397
      end;
398
    finally
399
      SaveDialog.Free;
400
    end;
401
  end;
402

403
  Result := (FTempName <> '');
404
  if Result then
405
  begin
406
    if FileExists(FTempName) then
407
    begin
408
      Result := (MessageDlg(Format('Overwrite file %s?', [FTempName]),
409
        mtConfirmation, [mbYes, mbNo], 0) = mrYes);
410
      // AVI streamers don't trim the file they're written to, so start from zero
411
      if Result then
412
        DeleteFile(FTempName);
413
    end;
414
  end;
415

416
  if not Result then
417
    Exit;
418

419
  AVIFileInit; // initialize the AVI lib.
420

421
  AVIBitmap := TBitmap.Create;
422
  AVIFrameIndex := 0;
423

424
  RecorderState := rsRecording;
425

426
  try
427
    AVIBitmap.PixelFormat := pf24Bit;
428
    AVIBitmap.Width := FWidth;
429
    AVIBitmap.Height := FHeight;
430

431
    // note: a filename with extension other then AVI give generate an error.
432
    if AVIFileOpen(pfile, PChar(FTempName), OF_WRITE or OF_CREATE, nil) <> AVIERR_OK
433
    then
434
      raise Exception.Create
435
        ('Cannot create AVI file. Disk full or file in use?');
436

437
    with AVIBitmap do
438
    begin
439
      InternalGetDIBSizes(Handle, bitmapInfoSize, FBitmapSize);
440
      FBitmapInfo := AllocMem(bitmapInfoSize);
441
      FBitmapBits := AllocMem(FBitmapSize);
442
      InternalGetDIB(Handle, FBitmapInfo^, FBitmapBits^);
443
    end;
444

445
    FillChar(asi, SizeOf(asi), 0);
446

447
    with asi do
448
    begin
449
      fccType := streamtypeVIDEO; // Now prepare the stream
450
      fccHandler := 0;
451
      dwScale := 1; // dwRate / dwScale = frames/second
452
      dwRate := FFPS;
453
      dwSuggestedBufferSize := FBitmapSize;
454
      rcFrame.Right := FBitmapInfo.biWidth;
455
      rcFrame.Bottom := FBitmapInfo.biHeight;
456
    end;
457

458
    if AVIFileCreateStream(pfile, Stream, asi) <> AVIERR_OK then
459
      raise Exception.Create('Cannot create AVI stream.');
460

461
    with AVIBitmap do
462
      InternalGetDIB(Handle, FBitmapInfo^, FBitmapBits^);
463

464
    galpAVIOptions := @gaAVIOptions;
465
    FillChar(gaAVIOptions, SizeOf(gaAVIOptions), 0);
466
    gaAVIOptions.fccType := streamtypeVIDEO;
467

468
    case FCompressor of
469
      acShowDialog:
470
        begin
471
          // call a dialog box for the user to choose the compressor options
472
          AVISaveOptions(0, ICMF_CHOOSE_KEYFRAME or ICMF_CHOOSE_DATARATE, 1,
473
            Stream, galpAVIOptions);
474
        end;
475
      acDivX:
476
        with gaAVIOptions do
477
        begin
478
          // ask for generic divx, using current default settings
479
          fccHandler := mmioFOURCC('d', 'i', 'v', 'x');
480
        end;
481
    else
482
      with gaAVIOptions do
483
      begin // or, you may want to fill the compression options yourself
484
        fccHandler := mmioFOURCC('M', 'S', 'V', 'C');
485
        // User MS video 1 as default.
486
        // I guess it is installed on every Win95 or later.
487
        dwQuality := 7500; // compress quality 0-10,000
488
        dwFlags := 0;
489
        // setting dwFlags to 0 would lead to some default settings
490
      end;
491
    end;
492

493
    AVIResult := AVIMakeCompressedStream(Stream_c, Stream, galpAVIOptions, nil);
494

495
    if AVIResult <> AVIERR_OK then
496
    begin
497
      if AVIResult = AVIERR_NOCOMPRESSOR then
498
        ResultString := 'No such compressor found'
499
      else
500
        ResultString := '';
501
      raise Exception.Create('Cannot make compressed stream. ' + ResultString);
502
    end;
503

504
    if AVIStreamSetFormat(Stream_c, 0, FBitmapInfo, bitmapInfoSize) <> AVIERR_OK
505
    then
506
      raise Exception.Create('AVIStreamSetFormat Error');
507
    // no error description found in MSDN.
508

509
    AVI_DPI := DPI;
510

511
  except
512
    CloseAVIFile(True);
513
    raise;
514
  end;
515

516
end;
517

518
procedure TGLAVIRecorder.CloseAVIFile(UserAbort: boolean = false);
519
begin
520
  // if UserAbort, CloseAVIFile will also delete the unfinished file.
521
  try
522
    if RecorderState <> rsRecording then
523
      raise Exception.Create('Cannot close AVI file. AVI file not created.');
524

525
    AVIBitmap.Free;
526

527
    FreeMem(FBitmapInfo);
528
    FreeMem(FBitmapBits);
529

530
    AVIFileExit; // finalize the AVI lib.
531

532
    // release the interfaces explicitly (can't rely on automatic release)
533
    Stream := nil;
534
    Stream_c := nil;
535
    pfile := nil;
536

537
    if UserAbort then
538
      DeleteFile(FTempName);
539
  finally
540
    RecorderState := rsNone;
541
  end;
542
end;
543

544
// Recording
545
//
546
function TGLAVIRecorder.Recording: boolean;
547
begin
548
  Result := (RecorderState = rsRecording);
549
end;
550

551
procedure TGLAVIRecorder.SetGLSceneViewer(const Value: TGLSceneViewer);
552
begin
553
  FGLSceneViewer := Value;
554
  if Assigned(FGLSceneViewer) then
555
    FBuffer := FGLSceneViewer.Buffer
556
  else
557
    FBuffer := nil;
558
end;
559

560
procedure TGLAVIRecorder.SetGLNonVisualViewer(const Value: TGLNonVisualViewer);
561
begin
562
  FGLNonVisualViewer := Value;
563
  if Assigned(FGLNonVisualViewer) then
564
    FBuffer := FGLNonVisualViewer.Buffer
565
  else
566
    FBuffer := nil;
567
end;
568

569
end.
570