path: root/Source/FsAviWriter.pas

unit FsAviWriter;

//
// FSAviWriter - Framestein modified version of AviWriter.
//

/////////////////////////////////////////////////////////////////////////////
//                                                                         //
//       AviWriter -- a component to create rudimentary AVI files          //
//                  by Elliott Shevin, with large pieces of code           //
//                  stolen from Anders Melander                            //
//       version 1.0. Please send comments, suggestions, and advice        //
//       to shevine@aol.com.                                               //
/////////////////////////////////////////////////////////////////////////////
//                                                                         //
//  AviWriter will build an AVI file containing one stream of any          //
//  number of TBitmaps, plus a single WAV file.                            //
//                                                                         //
//  Properties:                                                            //
//     Bitmaps : A TList of pointers to TBitmap objects which become       //
//               frames of the AVI video stream. The component             //
//               allocates and frees the TList, but the caller             //
//               is responsible for managing the TBitmaps themselves.      //
//               Manipulate the list as you would any other TList.         //
//               At least one bitmap is required.                          //
//     Height, Width:                                                      //
//               The dimensions of the AVI video, in pixels.               //
//     FrameTime:                                                          //
//               The duration of each video frame, in milliseconds.        //
//     Stretch:  If TRUE, each TBitmap on the Bitmaps list is              //
//               stretches to the dimensions specified in Height           //
//               and Width. If FALSE, each TBitmap is copied from          //
//               its upper left corner without stretching.                 //
//     FileName: The name of the AVI file to be written.                   //
//     WAVFileName:                                                        //
//               The name of a WAV file which will become the audio        //
//               stream for the AVI. Optional.                             //
//                                                                         //
//  Method:                                                                //
//      Write:  Creates the AVI file named by FileName.                    //
/////////////////////////////////////////////////////////////////////////////
//  Wish List:                                                             //
//    I'd like to be able to enhance this component in two ways, but       //
//    don't know how. Please send ideas to shevine@aol.com.                //
//       1. So far, it's necessary to transform the video stream into      //
//          and AVI file on disk. I'd prefer to do this in memory.         //
//       2. MIDI files for audio.                                          //
/////////////////////////////////////////////////////////////////////////////

interface

uses
  Windows,Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, DIB,
{$ifdef VER90}
  ole2;
{$else}
  ActiveX;
{$endif}

////////////////////////////////////////////////////////////////////////////////
//                                                                            //
//                      Video for Windows                                     //
//                                                                            //
////////////////////////////////////////////////////////////////////////////////
//                                                                            //
// Adapted from Thomas Schimming's VFW.PAS                                    //
// (c) 1996 Thomas Schimming, schimmin@iee1.et.tu-dresden.de                  //
// (c) 1998,99 Anders Melander                                                //
//                                                                            //
////////////////////////////////////////////////////////////////////////////////
//                                                                            //
// Ripped all COM/ActiveX stuff and added some AVI stream functions.          //
//                                                                            //
////////////////////////////////////////////////////////////////////////////////

type

 { TAVIFileInfoW record }

  LONG = Longint;
  PVOID = Pointer;

// TAVIFileInfo dwFlag values
const
  AVIF_HASINDEX		= $00000010;
  AVIF_MUSTUSEINDEX	= $00000020;
  AVIF_ISINTERLEAVED	= $00000100;
  AVIF_WASCAPTUREFILE	= $00010000;
  AVIF_COPYRIGHTED	= $00020000;
  AVIF_KNOWN_FLAGS	= $00030130;

    AVIERR_UNSUPPORTED              = $80044065; // MAKE_AVIERR(101)
    AVIERR_BADFORMAT                = $80044066; // MAKE_AVIERR(102)
    AVIERR_MEMORY                   = $80044067; // MAKE_AVIERR(103)
    AVIERR_INTERNAL                 = $80044068; // MAKE_AVIERR(104)
    AVIERR_BADFLAGS                 = $80044069; // MAKE_AVIERR(105)
    AVIERR_BADPARAM                 = $8004406A; // MAKE_AVIERR(106)
    AVIERR_BADSIZE                  = $8004406B; // MAKE_AVIERR(107)
    AVIERR_BADHANDLE                = $8004406C; // MAKE_AVIERR(108)
    AVIERR_FILEREAD                 = $8004406D; // MAKE_AVIERR(109)
    AVIERR_FILEWRITE                = $8004406E; // MAKE_AVIERR(110)
    AVIERR_FILEOPEN                 = $8004406F; // MAKE_AVIERR(111)
    AVIERR_COMPRESSOR               = $80044070; // MAKE_AVIERR(112)
    AVIERR_NOCOMPRESSOR             = $80044071; // MAKE_AVIERR(113)
    AVIERR_READONLY                 = $80044072; // MAKE_AVIERR(114)
    AVIERR_NODATA                   = $80044073; // MAKE_AVIERR(115)
    AVIERR_BUFFERTOOSMALL           = $80044074; // MAKE_AVIERR(116)
    AVIERR_CANTCOMPRESS             = $80044075; // MAKE_AVIERR(117)
    AVIERR_USERABORT                = $800440C6; // MAKE_AVIERR(198)
    AVIERR_ERROR                    = $800440C7; // MAKE_AVIERR(199)

type
  TAVIFileInfoW = record
    dwMaxBytesPerSec,	// max. transfer rate
    dwFlags,		// the ever-present flags
    dwCaps,
    dwStreams,
    dwSuggestedBufferSize,

    dwWidth,
    dwHeight,

    dwScale,
    dwRate,	// dwRate / dwScale == samples/second
    dwLength,

    dwEditCount: DWORD;

    szFileType: array[0..63] of WideChar;		// descriptive string for file type?
  end;
  PAVIFileInfoW = ^TAVIFileInfoW;

// TAVIStreamInfo dwFlag values
const
  AVISF_DISABLED	= $00000001;
  AVISF_VIDEO_PALCHANGES= $00010000;
  AVISF_KNOWN_FLAGS	= $00010001;

type
  TAVIStreamInfoA = record
    fccType,
    fccHandler,
    dwFlags,        // Contains AVITF_* flags
    dwCaps: DWORD;
    wPriority,
    wLanguage: WORD;
    dwScale,
    dwRate, // dwRate / dwScale == samples/second
    dwStart,
    dwLength, // In units above...
    dwInitialFrames,
    dwSuggestedBufferSize,
    dwQuality,
    dwSampleSize: DWORD;
    rcFrame: TRect;
    dwEditCount,
    dwFormatChangeCount: DWORD;
    szName:  array[0..63] of AnsiChar;
  end;
  TAVIStreamInfo = TAVIStreamInfoA;
  PAVIStreamInfo = ^TAVIStreamInfo;

  { TAVIStreamInfoW record }

  TAVIStreamInfoW = record
    fccType,
    fccHandler,
    dwFlags,        // Contains AVITF_* flags
    dwCaps: DWORD;
    wPriority,
    wLanguage: WORD;
    dwScale,
    dwRate, // dwRate / dwScale == samples/second
    dwStart,
    dwLength, // In units above...
    dwInitialFrames,
    dwSuggestedBufferSize,
    dwQuality,
    dwSampleSize: DWORD;
    rcFrame: TRect;
    dwEditCount,
    dwFormatChangeCount: DWORD;
    szName:  array[0..63] of WideChar;
  end;

  PAVIStream = pointer;
  PAVIFile = pointer;
  TAVIStreamList = array[0..0] of PAVIStream;
  PAVIStreamList = ^TAVIStreamList;
  TAVISaveCallback = function (nPercent: integer): LONG; stdcall;

  TAVICompressOptions = packed record
    fccType		: DWORD;
    fccHandler		: DWORD;
    dwKeyFrameEvery	: DWORD;
    dwQuality		: DWORD;
    dwBytesPerSecond	: DWORD;
    dwFlags		: DWORD;
    lpFormat		: pointer;
    cbFormat		: DWORD;
    lpParms		: pointer;
    cbParms		: DWORD;
    dwInterleaveEvery	: DWORD;
  end;
  PAVICompressOptions = ^TAVICompressOptions;

const
    ICMF_CHOOSE_KEYFRAME        = $0001;    // show KeyFrame Every box
    ICMF_CHOOSE_DATARATE        = $0002;    // show DataRate box
    ICMF_CHOOSE_PREVIEW         = $0004;    // allow expanded preview dialog

// Palette change data record
const
  RIFF_PaletteChange: DWORD = 1668293411;
type
  TAVIPalChange = packed record
    bFirstEntry		: byte;
    bNumEntries		: byte;
    wFlags		: WORD;
    peNew		: array[byte] of TPaletteEntry;
  end;
  PAVIPalChange = ^TAVIPalChange;

  APAVISTREAM          = array[0..1] of PAVISTREAM;
  APAVICompressOptions = array[0..1] of PAVICompressOptions;
  PAPAVICompressOptions = ^APAVICompressOptions;

procedure AVIFileInit; stdcall;
procedure AVIFileExit; stdcall;
function AVIFileOpen(var ppfile: PAVIFile; szFile: PChar; uMode: UINT; lpHandler: pointer): HResult; stdcall;
function AVIFileCreateStream(pfile: PAVIFile; var ppavi: PAVISTREAM; var psi: TAVIStreamInfo): HResult; stdcall;
function AVIStreamSetFormat(pavi: PAVIStream; lPos: LONG; lpFormat: pointer; cbFormat: LONG): HResult; stdcall;
function AVIStreamReadFormat(pavi: PAVIStream; lPos: LONG; lpFormat: pointer; var cbFormat: LONG): HResult; stdcall;
function AVIStreamWrite(pavi: PAVIStream; lStart, lSamples: LONG; lpBuffer: pointer; cbBuffer: LONG; dwFlags: DWORD; var plSampWritten: LONG; var plBytesWritten: LONG): HResult; stdcall;
function AVIStreamRelease(pavi: PAVISTREAM): ULONG; stdcall;
function AVIFileRelease(pfile: PAVIFile): ULONG; stdcall;
function AVIFileGetStream(pfile: PAVIFile; var ppavi: PAVISTREAM; fccType: DWORD; lParam: LONG): HResult; stdcall;
function CreateEditableStream(var ppsEditable: PAVISTREAM; psSource: PAVISTREAM): HResult; stdcall;
function AVISaveV(szFile: PChar; pclsidHandler: PCLSID; lpfnCallback: TAVISaveCallback;
  nStreams: integer; pavi: APAVISTREAM; lpOptions: APAVICompressOptions): HResult; stdcall;
function AVISaveOptions(hwnd: HWND; uiFlags: UINT; nStreams: integer;
 ppavi: APAVISTREAM; plpOptions: PAPAVICOMPRESSOPTIONS): Boolean; stdcall; external 'avifil32.dll';
function AVIMakeCompressedStream(var ppaviCompressed: PAVISTREAM;
 ppaviSource: PAVISTREAM; plpOptions: APAVICompressOptions;
 pclsidHandler: PCLSID): HResult; stdcall; external 'avifil32.dll';

const
  AVIERR_OK       = 0;

  AVIIF_LIST      = $01;
  AVIIF_TWOCC	  = $02;
  AVIIF_KEYFRAME  = $10;

  streamtypeVIDEO = $73646976; // DWORD( 'v', 'i', 'd', 's' )
  streamtypeAUDIO = $73647561; // DWORD( 'a', 'u', 'd', 's' )


type
  TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit,
                     pf24bit, pf32bit, pfCustom);

type
  TAviWriter = class(TComponent)
  private
    TempFileName   : string;
    pFile          : PAVIFile;
    fHeight        : integer;
    fWidth         : integer;
    fStretch       : boolean;
    fFrameTime     : integer;
    fFileName      : string;
    fWavFileName   : string;
    VideoStream    : PAVISTREAM;
    AudioStream    : PAVISTREAM;

    Pstream        : PAVISTREAM;
    StreamInfo	   : TAVIStreamInfo;

    CompOptions           : APAVICompressOptions;
    cmp1, cmp2            : TAviCompressOptions;

    procedure AddVideo;
    procedure AddAudio;
    procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
        var ImageSize: longInt; PixelFormat: TPixelFormat);
    function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
        var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
    procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader;
           PixelFormat: TPixelFormat);
    procedure SetWavFileName(value : string);
    { Private declarations }
  protected
    { Protected declarations }
  public
    Bitmaps : TList;
    FramePos       : Longint;
    Prepared       : Boolean;
    fps            : Integer;
    constructor Create(AOwner : TComponent); override;
    destructor  Destroy; override;
    procedure Write;
    procedure Prepare;
    procedure AddFrame(const DIB: TDIB);
    procedure Finish;
    { Public declarations }
  published
    property Height   : integer read fHeight  write fHeight;
    property Width    : integer read fWidth   write fWidth;
    property FrameTime: integer read fFrameTime write fFrameTime;
    property Stretch  : boolean read fStretch write fStretch;
    property FileName : string  read fFileName write fFileName;
    property WavFileName  : string  read fWavFileName write SetWavFileName;
    { Published declarations }
  end;

procedure Register;

implementation

uses
  mainunit,
  progressunit;

function MAKEFOURCC(ch0, ch1, ch2, ch3: Char): Cardinal;
begin
  Result :=
    (DWORD(BYTE(ch0))) or (DWORD(BYTE(ch1)) shl 8) or
    (DWORD(BYTE(ch2)) shl 16) or (DWORD(BYTE(ch3)) shl 24 );
end;

constructor TAviWriter.Create(AOwner : TComponent);
var
  tempdir               : string;
  l                     : integer;
begin
    inherited Create(AOwner);
    fHeight    := screen.height div 10;
    fWidth     := screen.width  div 10;
    fFrameTime := 1000;
    fStretch   := true;
    fFileName  := '';
    Bitmaps    := TList.create;
    AVIFileInit;

    setlength(tempdir,MAX_PATH + 1);
    l := GetTempPath(MAX_PATH,pchar(tempdir));
    setlength(tempdir,l);
    if copy(tempdir,length(tempdir),1) <> '\'
       then tempdir := tempdir + '\';
    TempFileName := tempdir + '~AWTemp.avi';
    Prepared := False;

  CompOptions[0] := @cmp1;
  CompOptions[1] := @cmp2;

  FillChar(cmp1, Sizeof(cmp1), 0);
  FillChar(cmp2, Sizeof(cmp1), 0);

  cmp1.fccType := streamtypeVIDEO;
  cmp1.fccHandler := MakeFourCC('m','j','p','g');
//  cmp1.dwQuality :=

  fps := 25;
end;

destructor TAviWriter.Destroy;
begin
    Bitmaps.free;
    AviFileExit;
    inherited;
end;

procedure TAviWriter.Write;
var
  Bitmap                : TBitmap;
  ExtBitmap             : TBitmap;
  nstreams              : integer;
  i                     : integer;
  Streams               : APAVISTREAM;
  CompOptions           : APAVICompressOptions;
  AVIERR                : integer;
  refcount              : integer;
begin
    AudioStream := nil;
    VideoStream := nil;

    // If no bitmaps are on the list, raise an error.
    if Bitmaps.count < 1 then
        raise Exception.Create('No bitmaps on the Bitmaps list');

    // If anything on the Bitmaps TList is not a bitmap, raise
    // an error.
    for i := 0 to Bitmaps.count - 1 do begin
       ExtBitmap := Bitmaps[i];
       if not(ExtBitmap is TBitmap)
          then raise Exception.Create('Bitmaps[' + inttostr(i)
                          + '] is not a TBitmap');
    end;

    try
      AddVideo;

      if WavFileName <> ''
         then AddAudio;

      // Create the output file.
      if WavFileName <> ''
         then nstreams := 2
         else nstreams := 1;

      Streams[0] := VideoStream;
      Streams[1] := AudioStream;
      CompOptions[0] := nil;
      CompOptions[1] := nil;

      AVIERR := AVISaveV(pchar(FileName),
                   nil,                    // File handler
                   nil,                    // Callback
                   nStreams,               // Number of streams
                   Streams,
                   CompOptions);           // Compress options for VideoStream
      if AVIERR <> AVIERR_OK then
             raise Exception.Create('Unable to write output file');
    finally
      if assigned(VideoStream)
         then AviStreamRelease(VideoStream);
      if assigned(AudioStream)
         then AviStreamRelease(AudioStream);

      try
         repeat
            refcount := AviFileRelease(pFile);
         until refcount <= 0;
      except
      end;

      DeleteFile(TempFileName);
    end;
end;

procedure TAviWriter.AddVideo;
var
  Pstream               : PAVISTREAM;
  StreamInfo		: TAVIStreamInfo;
  BitmapInfo		: PBitmapInfoHeader;
  BitmapInfoSize	: Integer;
  BitmapSize		: longInt;
  BitmapBits		: pointer;
  Bitmap                : TBitmap;
  ExtBitmap             : TBitmap;
  Samples_Written       : LONG;
  Bytes_Written         : LONG;
  AVIERR                : integer;
  i                     : integer;
  startpos              : DWORD;
  len                   : DWORD;
begin

    // Open AVI file for write
    if (AVIFileOpen(pFile, pchar(TempFileName),
            OF_WRITE or OF_CREATE OR OF_SHARE_EXCLUSIVE, nil)
         <> AVIERR_OK)
      then
        raise Exception.Create('Failed to create AVI video work file');

    // Allocate the bitmap to which the bitmaps on the Bitmaps Tlist
    // will be copied.
    Bitmap        := TBitmap.create;
    Bitmap.Height := self.Height;
    Bitmap.Width  := self.Width;

    // Write the stream header.
    try
       FillChar(StreamInfo, sizeof(StreamInfo), 0);

       // Set frame rate and scale
       StreamInfo.dwRate := 1000;
       StreamInfo.dwScale := fFrameTime;
       StreamInfo.fccType := streamtypeVIDEO;
       StreamInfo.fccHandler := 0;
       StreamInfo.dwFlags := 0;
       StreamInfo.dwSuggestedBufferSize := 0;
       StreamInfo.rcFrame.Right := self.width;
       StreamInfo.rcFrame.Bottom := self.height;

       // Open AVI data stream
       if (AVIFileCreateStream(pFile, pStream, StreamInfo) <> AVIERR_OK) then
           raise Exception.Create('Failed to create AVI video stream');

       try
          // Write the bitmaps to the stream.
          for i := 0 to Bitmaps.count - 1 do begin
             try
               BitmapInfo := nil;
               BitmapBits := nil;

               // Copy the bitmap from the list to the AVI bitmap,
               // stretching if desired. If the caller elects not to
               // stretch, use the first pixel in the bitmap as a
               // background color in case either the height or
               // width of the source is smaller than the output.
               // If Draw fails, do a StretchDraw.
               ExtBitmap := Bitmaps[i];
               if fStretch
                  then Bitmap.Canvas.StretchDraw
                           (Rect(0,0,self.width,self.height),ExtBitmap)
                  else try
                         with Bitmap.Canvas do begin
                            Brush.Color := ExtBitmap.Canvas.Pixels[0,0];
                            Brush.Style := bsSolid;
                            FillRect(Rect(0,0,Bitmap.Width,Bitmap.Height));
                            Draw(0,0,ExtBitmap);
                         end;
                       except
                         Bitmap.Canvas.StretchDraw
                            (Rect(0,0,self.width,self.height),ExtBitmap);
                       end;

               // Determine size of DIB
               InternalGetDIBSizes(Bitmap.Handle, BitmapInfoSize, BitmapSize, pf8bit);
               if (BitmapInfoSize = 0) then
                  raise Exception.Create('Failed to retrieve bitmap info');

               // Get DIB header and pixel buffers
               GetMem(BitmapInfo, BitmapInfoSize);
               GetMem(BitmapBits, BitmapSize);
               InternalGetDIB
                     (Bitmap.Handle, 0, BitmapInfo^, BitmapBits^, pf8bit);

               // On the first time through, set the stream format.
               if i = 0 then
                  if (AVIStreamSetFormat(pStream, 0, BitmapInfo, BitmapInfoSize) <> AVIERR_OK) then
                      raise Exception.Create('Failed to set AVI stream format');

               // Write frame to the video stream
               AVIERR :=
                  AVIStreamWrite(pStream, i, 1, BitmapBits, BitmapSize, AVIIF_KEYFRAME,
                             Samples_Written, Bytes_Written);
               if AVIERR <> AVIERR_OK then
                    raise Exception.Create
                            ('Failed to add frame to AVI. Err='
                               + inttohex(AVIERR,8));
             finally
               if (BitmapInfo <> nil) then
                 FreeMem(BitmapInfo);
               if (BitmapBits <> nil) then
                 FreeMem(BitmapBits);
             end;
          end;

          // Create the editable VideoStream from pStream.
          if CreateEditableStream(VideoStream,pStream) <> AVIERR_OK then
                    raise Exception.Create
                            ('Could not create Video Stream');
       finally
          AviStreamRelease(pStream);
       end;

    finally
      Bitmap.free;
    end;
end;

procedure TAviWriter.AddAudio;
var
   InputFile    : PAVIFILE;
   hr           : integer;
   InputStream  : PAVIStream;
   avisClip     : TAVISTREAMINFO;
   l, selstart  : DWORD;
   pastecode    : integer;
begin
   // Open the audio file.
   hr := AVIFileOpen(InputFile, pchar(WavFileName),OF_READ, nil);
   case hr of
        0:     ;
        AVIERR_BADFORMAT  : raise Exception.Create('The file could not be read, indicating a corrupt file or an unrecognized format.');
        AVIERR_MEMORY     : raise Exception.Create('The file could not be opened because of insufficient memory.');
        AVIERR_FILEREAD   : raise Exception.Create('A disk error occurred while reading the audio file.');
        AVIERR_FILEOPEN   : raise Exception.Create('A disk error occurred while opening the audio file.');
        REGDB_E_CLASSNOTREG : raise Exception.Create('According to the registry, the type of audio file specified in AVIFileOpen does not have a handler to process it.');
        else raise Exception.Create('Unknown error opening audio file');
   end;

   // Open the audio stream.
   try
     if (AVIFileGetStream(InputFile, InputStream, 0, 0) <> AVIERR_OK) then
         raise Exception.Create('Unable to get audio stream');

     try
       // Create AudioStream as a copy of InputStream
       if (CreateEditableStream(AudioStream,InputStream) <> AVIERR_OK) then
            raise Exception.Create('Failed to create editable AVI audio stream');
     finally
       AviStreamRelease(InputStream);
     end;

   finally
     AviFileRelease(InputFile);
   end;
end;

// --------------
// InternalGetDIB
// --------------
// Converts a bitmap to a DIB of a specified PixelFormat.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// Pal		The handle of the source palette.
// BitmapInfo	The buffer that will receive the DIB's TBitmapInfo structure.
//		A buffer of sufficient size must have been allocated prior to
//		calling this function.
// Bits		The buffer that will receive the DIB's pixel data.
//		A buffer of sufficient size must have been allocated prior to
//		calling this function.
// PixelFormat	The pixel format of the destination DIB.
//
// Returns:
// True on success, False on failure.
//
// Note: The InternalGetDIBSizes function can be used to calculate the
// nescessary sizes of the BitmapInfo and Bits buffers.
//
function TAviWriter.InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
  var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
// From graphics.pas, "optimized" for our use
var
  OldPal	: HPALETTE;
  DC		: HDC;
begin
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);
  OldPal := 0;
  DC := CreateCompatibleDC(0);
  try
    if (Palette <> 0) then
    begin
      OldPal := SelectPalette(DC, Palette, False);
      RealizePalette(DC);
    end;
    Result := (GetDIBits(DC, Bitmap, 0, abs(TBitmapInfoHeader(BitmapInfo).biHeight),
      @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0);
  finally
    if (OldPal <> 0) then
      SelectPalette(DC, OldPal, False);
    DeleteDC(DC);
  end;
end;


// -------------------
// InternalGetDIBSizes
// -------------------
// Calculates the buffer sizes nescessary for convertion of a bitmap to a DIB
// of a specified PixelFormat.
// See the GetDIBSizes API function for more info.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// InfoHeaderSize
//		The returned size of a buffer that will receive the DIB's
//		TBitmapInfo structure.
// ImageSize	The returned size of a buffer that will receive the DIB's
//		pixel data.
// PixelFormat	The pixel format of the destination DIB.
//
procedure TAviWriter.InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
  var ImageSize: longInt; PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
  Info		: TBitmapInfoHeader;
begin
  InitializeBitmapInfoHeader(Bitmap, Info, PixelFormat);
  // Check for palette device format
  if (Info.biBitCount > 8) then
  begin
    // Header but no palette
    InfoHeaderSize := SizeOf(TBitmapInfoHeader);
    if ((Info.biCompression and BI_BITFIELDS) <> 0) then
      Inc(InfoHeaderSize, 12);
  end else
    // Header and palette
    InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl Info.biBitCount);
  ImageSize := Info.biSizeImage;
end;

// --------------------------
// InitializeBitmapInfoHeader
// --------------------------
// Fills a TBitmapInfoHeader with the values of a bitmap when converted to a
// DIB of a specified PixelFormat.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// Info		The TBitmapInfoHeader buffer that will receive the values.
// PixelFormat	The pixel format of the destination DIB.
//
{$IFDEF BAD_STACK_ALIGNMENT}
  // Disable optimization to circumvent optimizer bug...
  {$IFOPT O+}
    {$DEFINE O_PLUS}
    {$O-}
  {$ENDIF}
{$ENDIF}


procedure TAviWriter.InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader;
  PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
  DIB		: TDIBSection;
  Bytes		: Integer;
  function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
  begin
    Dec(Alignment);
    Result := ((Bits * BitsPerPixel) + Alignment) and not Alignment;
    Result := Result SHR 3;
  end;
begin
  DIB.dsbmih.biSize := 0;
  Bytes := GetObject(Bitmap, SizeOf(DIB), @DIB);
  if (Bytes = 0) then
    raise Exception.Create('Invalid bitmap');
//    Error(sInvalidBitmap);

  if (Bytes >= (sizeof(DIB.dsbm) + sizeof(DIB.dsbmih))) and
    (DIB.dsbmih.biSize >= sizeof(DIB.dsbmih)) then
    Info := DIB.dsbmih
  else
  begin
    FillChar(Info, sizeof(Info), 0);
    with Info, DIB.dsbm do
    begin
      biSize := SizeOf(Info);
      biWidth := bmWidth;
      biHeight := bmHeight;
    end;
  end;
  case PixelFormat of
    pf1bit: Info.biBitCount := 1;
    pf4bit: Info.biBitCount := 4;
    pf8bit: Info.biBitCount := 8;
    pf24bit: Info.biBitCount := 24;
  else
//    Error(sInvalidPixelFormat);
    raise Exception.Create('Invalid pixel foramt');
    // Info.biBitCount := DIB.dsbm.bmBitsPixel * DIB.dsbm.bmPlanes;
  end;
  Info.biPlanes := 1;
  Info.biCompression := BI_RGB; // Always return data in RGB format
  Info.biSizeImage := AlignBit(Info.biWidth, Info.biBitCount, 32) * Cardinal(abs(Info.biHeight));
end;
{$IFDEF O_PLUS}
  {$O+}
  {$UNDEF O_PLUS}
{$ENDIF}

procedure TAviWriter.SetWavFileName(value : string);
begin
   if lowercase(fWavFileName) <> lowercase(value)
      then if lowercase(ExtractFileExt(value)) <> '.wav'
             then raise Exception.Create('WavFileName must name a file '
                             + 'with the .wav extension')
             else fWavFileName := value;
end;


procedure Register;
begin
  RegisterComponents('Labrz', [TAviWriter]);
end;

  procedure AVIFileInit; stdcall; external 'avifil32.dll' name 'AVIFileInit';
  procedure AVIFileExit; stdcall; external 'avifil32.dll' name 'AVIFileExit';
  function AVIFileOpen; external 'avifil32.dll' name 'AVIFileOpenA';
  function AVIFileCreateStream; external 'avifil32.dll' name 'AVIFileCreateStreamA';
  function AVIStreamSetFormat; external 'avifil32.dll' name 'AVIStreamSetFormat';
  function AVIStreamReadFormat; external 'avifil32.dll' name 'AVIStreamReadFormat';
  function AVIStreamWrite; external 'avifil32.dll' name 'AVIStreamWrite';
  function AVIStreamRelease; external 'avifil32.dll' name 'AVIStreamRelease';
  function AVIFileRelease; external 'avifil32.dll' name 'AVIFileRelease';
  function AVIFileGetStream; external 'avifil32.dll' name 'AVIFileGetStream';
  function CreateEditableStream; external 'avifil32.dll' name 'CreateEditableStream';
  function AVISaveV; external 'avifil32.dll' name 'AVISaveV';

procedure TAviWriter.Prepare;
begin
  if Prepared then begin
    main.Post('Finishing previous file..');
    Finish;
  end;

  AudioStream := nil;
  VideoStream := nil;

  if (AVIFileOpen(pFile, pchar(TempFileName),
   OF_WRITE or OF_CREATE or OF_SHARE_EXCLUSIVE, nil) <> AVIERR_OK) then
    raise Exception.Create('Failed to create AVI video work file');

  FillChar(StreamInfo, sizeof(StreamInfo), 0);

  // Set frame rate and scale
  StreamInfo.dwRate := fps*1000;
  StreamInfo.dwScale := fFrameTime;
  StreamInfo.fccType := streamtypeVIDEO;
  StreamInfo.fccHandler := 0;
  StreamInfo.dwFlags := 0;
  StreamInfo.dwSuggestedBufferSize := 0;
  StreamInfo.rcFrame.Right := self.width;
  StreamInfo.rcFrame.Bottom := self.height;

  // Open AVI data stream
  if (AVIFileCreateStream(pFile, pStream, StreamInfo) <> AVIERR_OK) then
    raise Exception.Create('Failed to create AVI video stream');

  FramePos := 0;
  Prepared := True;
end;

procedure TAviWriter.AddFrame(const DIB: TDIB);
var
  Samples_Written       : LONG;
  Bytes_Written         : LONG;
  AVIERR                : integer;
begin
  if not Prepared then begin
    main.Post('fs.avi: internal error, not prepared to add frame.');
    Exit;
  end;

  // On the first time through, set the stream format.
  if FramePos = 0 then begin
    if (AVIStreamSetFormat(pStream, 0, DIB.BitmapInfo, DIB.BitmapInfoSize) <> AVIERR_OK) then
      raise Exception.Create('Failed to set AVI stream format');
  end;

  // Write frame to the video stream
  AVIERR := AVIStreamWrite(pStream, FramePos, 1, DIB.PBits, DIB.Size, AVIIF_KEYFRAME,
   Samples_Written, Bytes_Written);

  Inc(FramePos);

  if AVIERR <> AVIERR_OK then
    raise Exception.Create('Failed to add frame to AVI. Err='+
     inttohex(AVIERR,8));
end;

function avisavecallback(nPercent: UINT): ULONG; stdcall;
begin
//  Write('fs.avi: '+IntToStr(nPercent)+'%'+#13);
  Progress.pb1.Position := nPercent;
  Result := AVIERR_OK;
end;

procedure TAviWriter.Finish;
var
  nstreams: Integer;
  Streams               : APAVISTREAM;
  AVIERR                : integer;
  refcount              : integer;
begin
  if not Prepared then begin
    main.Post('fs.avi: nothing to write.');
    Exit;
  end;

  if CreateEditableStream(VideoStream,pStream) <> AVIERR_OK then
    raise Exception.Create('Could not create Video Stream');

  AviStreamRelease(pStream);

  nstreams := 1;

  Streams[0] := VideoStream;
  Streams[1] := nil;//AudioStream;

  if AVISaveOptions(0, ICMF_CHOOSE_PREVIEW, nStreams, Streams, @CompOptions) then begin

    Progress.Show;

    AVIERR := AVISaveV(pchar(FileName),
               nil,                    // File handler
               @avisavecallback,       // Callback
               nStreams,               // Number of streams
               Streams,
               CompOptions);           // Compress options for VideoStream

    Progress.Hide;

// I get some strange error but the file is always ok so... screw it
{
    if AVIERR <> AVIERR_OK then
      raise Exception.Create('Error on write - check output file.');
}
    if assigned(VideoStream)
      then AviStreamRelease(VideoStream);
    if assigned(AudioStream)
      then AviStreamRelease(AudioStream);

    try
      repeat
        refcount := AviFileRelease(pFile);
      until refcount <= 0;
    except
    end;

    DeleteFile(TempFileName);

    Prepared := False;
  end;
end;

end.