unit AviMaker;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics,
  ActiveX, VFW;

type
  TAviMaker = class
   private
    TempFileName    : String;
    pFile           : PAVIFile;
    VideoStream     : PAVISTREAM;

    function GetDIB(const HBMP : HBITMAP; const Palette : HPALETTE;
                    var BitmapInfo, Bits; const PixelFormat : TPixelFormat) : BOOL;
    procedure AddVideo;
    procedure GetDIBSizes(const HBMP : HBITMAP; const PixelFormat : TPixelFormat;
                          var InfoHeaderSize : Integer;
                          var ImageSize : LongInt);
    procedure InitBitmapInfoHeader(const HBMP : HBITMAP;
                                   const PixelFormat : TPixelFormat;
                                   var Info : TBitmapInfoHeader);
   { Private declarations }
  protected
    { Protected declarations }
  public
    Bitmaps   : TList;
    Height    : Integer;
    Width     : Integer;
    FrameTime : Integer;
    Stretch   : BOOL;
    FileName  : String;
    PixelFormat  : TPixelFormat;
    constructor Create;
    destructor Destroy; override;
    procedure Write;
    { Public declarations }
  end;

implementation

constructor TAviMaker.Create;
var
  TempDir : String;
  i : Integer;
begin
  inherited;
  Height    := 0;
  Width     := 0;
  FrameTime := 1000;
  Stretch   := True;
  FileName  := '';
  Bitmaps   := TList.Create;
  PixelFormat := pf8bit;

  AVIFileInit;

  SetLength(TempDir, MAX_PATH + 1);
  i := GetTempPath(MAX_PATH, PChar(TempDir));
  SetLength(TempDir, i);
  if Copy(TempDir, Length(TempDir), 1) <> '\' then TempDir := TempDir + '\';
  TempFileName := TempDir + '~Temp.avi';
end;

destructor TAviMaker.Destroy;
begin
  Bitmaps.Free;
  AviFileExit;
  inherited;
end;

procedure TAviMaker.Write;
var
  CompOption : PAVICompressOptions;
  refCount : Integer;
begin
  VideoStream := nil;

  if Bitmaps.Count < 1 then raise Exception.Create('No bitmaps on the Bitmaps list');

  try
    AddVideo;

    CompOption := nil;

    if AVISaveV(PChar(FileName), nil, nil, 1, VideoStream, CompOption) <> AVIERR_OK
       then raise Exception.Create('Unable to write output file');
       
  finally
    if Assigned(VideoStream) then AviStreamRelease(VideoStream);

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

    DeleteFile(TempFileName);
  end;
end;

{$WARNINGS OFF}
procedure TAviMaker.AddVideo;
var
  Pstream          : PAVISTREAM;
  StreamInfo	   : TAVIStreamInfo;
  BitmapInfo	   : PBitmapInfoHeader;
  BitmapInfoSize   : Integer;
  BitmapSize	   : LongInt;
  BitmapBits	   : Pointer;
  tmpBitmap        : TBitmap;
  wrkBitmap        : TBitmap;
  Samples_Written  : Long;
  Bytes_Written    : Long;
  i                : Integer;
begin
  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');

  tmpBitmap        := TBitmap.Create;
  tmpBitmap.Height := Self.Height;
  tmpBitmap.Width  := Self.Width;

  try
     ZeroMemory (@StreamInfo, SizeOf(StreamInfo));

     with StreamInfo do begin
          dwRate := 1000;
          dwScale := FrameTime;
          fccType := streamtypeVIDEO;
          fccHandler := 0;
          dwFlags := 0;
          dwSuggestedBufferSize := 0;
          rcFrame.Right := Self.Width;
          rcFrame.Bottom := Self.Height;
     end;

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

     try
        for i := 0 to Bitmaps.Count - 1 do begin
           try
             BitmapInfo := nil;
             BitmapBits := nil;

             wrkBitmap := Bitmaps[i];

             if Stretch
                then tmpBitmap.Canvas.StretchDraw
                         (Rect(0, 0, Self.Width, Self.Height), wrkBitmap)
                else try
                       with tmpBitmap.Canvas do begin
                          Brush.Color := wrkBitmap.Canvas.Pixels[0, 0];
                          Brush.Style := bsSolid;
                          FillRect(Rect(0, 0, tmpBitmap.Width, tmpBitmap.Height));
                          Draw(0, 0, wrkBitmap);
                       end;
                     except
                       tmpBitmap.Canvas.StretchDraw
                          (Rect(0, 0, Self.Width, Self.Height), wrkBitmap);
             end;

             GetDIBSizes(tmpBitmap.Handle, PixelFormat, BitmapInfoSize, BitmapSize);
             if BitmapInfoSize = 0 then raise Exception.Create('Failed to retrieve bitmap info');

             GetMem(BitmapInfo, BitmapInfoSize);
             GetMem(BitmapBits, BitmapSize);
             GetDIB(tmpBitmap.Handle, 0, BitmapInfo^, BitmapBits^, PixelFormat);

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

             if AVIStreamWrite(pStream, i, 1, BitmapBits, BitmapSize, AVIIF_KEYFRAME,
                               Samples_Written, Bytes_Written) <> AVIERR_OK
                then raise Exception.Create ('Failed to add frame to AVI.');
           finally
             if BitmapInfo <> nil then FreeMem(BitmapInfo);
             if BitmapBits <> nil then FreeMem(BitmapBits);
           end;
        end;

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

  finally
    wrkBitmap.Free;  
    tmpBitmap.Free;
  end;
end;
{$WARNINGS ON}

function TAviMaker.GetDIB(const HBMP : HBITMAP; const Palette : HPALETTE;
                           var BitmapInfo, Bits;
                           const PixelFormat : TPixelFormat) : BOOL;
var
  OldPal : HPALETTE;
  DC : HDC;
begin
  InitBitmapInfoHeader(HBMP, PixelFormat, TBitmapInfoHeader(BitmapInfo));
  OldPal := 0;
  DC := CreateCompatibleDC(0);
  try
    if Palette <> 0 then begin
      OldPal := SelectPalette(DC, Palette, False);
      RealizePalette(DC);
    end;
    Result := (GetDIBits(DC, HBMP, 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;

procedure TAviMaker.GetDIBSizes(const HBMP : HBITMAP; const PixelFormat : TPixelFormat;
                                 var InfoHeaderSize : Integer;
                                 var ImageSize : LongInt);
var
  BIH : TBitmapInfoHeader;
begin
  InitBitmapInfoHeader(HBMP, PixelFormat, BIH);
  if BIH.biBitCount > 8 then begin
    InfoHeaderSize := SizeOf(TBitmapInfoHeader);
    if (BIH.biCompression and BI_BITFIELDS) <> 0 then Inc(InfoHeaderSize, 12);
    end else
    InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl BIH.biBitCount);
  ImageSize := BIH.biSizeImage;
end;

procedure TAviMaker.InitBitmapInfoHeader(const HBMP : HBITMAP;
                                         const PixelFormat : TPixelFormat;
                                         var Info : TBitmapInfoHeader);
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(HBMP, SizeOf(DIB), @DIB);
  if Bytes = 0 then raise Exception.Create('Invalid bitmap');

  if (Bytes >= (SizeOf(DIB.dsbm) + SizeOf(DIB.dsbmih))) and
    (DIB.dsbmih.biSize >= SizeOf(DIB.dsbmih))
    then Info := DIB.dsbmih
    else begin
    ZeroMemory (@Info, SizeOf(Info));
    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 raise Exception.Create('Invalid pixel foramt');
  end;
  with Info do begin
    biPlanes := 1;
    biCompression := BI_RGB;
    biSizeImage := AlignBit(biWidth, biBitCount, 32) * Cardinal(abs(biHeight));
  end;
end;

end.
