bmp2avi.pas

经过研究本人初略的将原代码进行了模拟

unit bmp2avi;

interface
uses
  Windows, SysUtils, Graphics, Dialogs,
{$IFDEF VER90}
  ole2;
{$ELSE}
  ActiveX;
{$ENDIF}
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;
  TAVISaveCallback = function(nPercent: integer): LONGint; stdcall;
function AVIFileOpen(var ppfile: pointer; szFile: PChar; uMode: UINT; lpHandler: pointer): HResult; stdcall;
procedure AVIFileInit; stdcall;
procedure AVIFileExit; stdcall;
function AVIFileCreateStream(pfile: pointer; var ppavi: pointer; var psi: TAVIStreamInfo): HResult; stdcall;
function AVIStreamSetFormat(pavi: pointer; lPos: LONGint; lpFormat: pointer; cbFormat: LONGint): HResult; stdcall;
function AVIStreamWrite(pavi: pointer; lStart, lSamples: LONGint; lpBuffer: pointer; cbBuffer: LONGint; dwFlags: DWORD; var plSampWritten: LONGint; var plBytesWritten: LONGint): HResult; stdcall;
function AVIStreamRelease(pavi: pointer): ULONG; stdcall;
function AVIFileRelease(pfile: pointer): ULONG; stdcall;
function CreateEditableStream(var ppsEditable: pointer; psSource: pointer): HResult; stdcall;
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer; var ImageSize: longInt; PixelFormat: TPixelFormat);
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader; PixelFormat: TPixelFormat);
function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;

const
  streamtypeVIDEO                       = $73646976;        // DWORD( 'v', 'i', 'd', 's' )
  AVIIF_KEYFRAME                        = $10;

type
  TAvi = class(TObject)
  private
    pFile, pStream, BitmapBits: pointer;
    StreamInfo: TAVIStreamInfo;
    BitmapInfo: PBitmapInfoHeader;
    BitmapInfoSize: Integer;
    BitmapSize, Dummy: longInt;
    apxf: TPixelFormat;
    i: Integer;
  public
    constructor Create(as_avifile: string; bmp: TBitmap; fPxf: TPixelFormat = pf8bit; AviRate: integer = 1);
    destructor Destroy; override;
    procedure Add(bmp: TBitmap);
  end;
implementation

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 AVIStreamWrite; external 'avifil32.dll' name 'AVIStreamWrite';
function AVIStreamRelease; external 'avifil32.dll' name 'AVIStreamRelease';
function AVIFileRelease; external 'avifil32.dll' name 'AVIFileRelease';
function CreateEditableStream; external 'avifil32.dll' name 'CreateEditableStream';

constructor TAvi.Create(as_avifile: string; bmp: TBitmap; fPxf: TPixelFormat = pf8bit; AviRate: integer = 1);
begin
  inherited Create;
  apxf := fPxf;
  i := 0;
  AVIFileInit;

  if (AVIFileOpen(pFile, PChar(as_avifile), OF_WRITE or OF_CREATE or OF_SHARE_EXCLUSIVE, nil) <> 0) then
    raise Exception.Create('创建avi文件失败');

  InternalGetDIBSizes(bmp.Handle, BitmapInfoSize, BitmapSize, fPxf);
  FillChar(StreamInfo, sizeof(StreamInfo), 0);
  StreamInfo.fccType := streamtypeVIDEO;
  StreamInfo.fccHandler := 0;
  StreamInfo.dwFlags := 0;
  StreamInfo.dwSuggestedBufferSize := BitmapSize;
  StreamInfo.rcFrame.Right := bmp.Width;
  StreamInfo.rcFrame.Bottom := bmp.Height;
  StreamInfo.dwScale := 1;
  StreamInfo.dwRate := AviRate;

  if (AVIFileCreateStream(pFile, pStream, StreamInfo) <> 0) then
    raise Exception.Create('创建avi流失败');

  BitmapInfo := nil;
  BitmapBits := nil;
  // Get DIB header and pixel buffers
  GetMem(BitmapInfo, BitmapInfoSize);
  GetMem(BitmapBits, BitmapSize);
  InternalGetDIB(bmp.Handle, 0, BitmapInfo^, BitmapBits^, apxf);
  if (AVIStreamSetFormat(pStream, 0, BitmapInfo, BitmapInfoSize) <> 0) then
    raise Exception.Create('设置avi流格式失败');

end;

destructor TAvi.Destroy;
begin
  if (BitmapInfo <> nil) then
    FreeMem(BitmapInfo);
  if (BitmapBits <> nil) then
    FreeMem(BitmapBits);
  AVIStreamRelease(pStream);
  AVIFileRelease(pFile);
  AVIFileExit;
  inherited Destroy;
end;

procedure TAvi.Add(bmp: TBitmap);
begin
  try
    InternalGetDIB(bmp.Handle, 0, BitmapInfo^, BitmapBits^, apxf);
    if AVIStreamWrite(pStream, i, 1, BitmapBits, BitmapSize, AVIIF_KEYFRAME, Dummy, Dummy) <> 0 then
      raise Exception.Create('添加帧到avi文件失败');
    Inc(i);
  except
    Destroy;
  end;
end;

function 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;

procedure 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;

procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader;
  PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
  DIB                                   : TDIBSection;
  Bytes                                 : Integer;
begin
  DIB.dsbmih.biSize := 0;
  Bytes := GetObject(Bitmap, SizeOf(DIB), @DIB);
  if (Bytes = 0) then
    showmessage('出错');

  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;
    pf15bit: Info.biBitCount := 15;
    pf16bit: Info.biBitCount := 16;
    pf24bit: Info.biBitCount := 24;
  else
    showmessage('出错');
    // 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;

function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
begin
  Dec(Alignment);
  Result := ((Bits * BitsPerPixel) + Alignment) and not Alignment;
  Result := Result shr 3;
end;
end.