bmptoavi.pas

音视频控件SunAM-V1.0 音视频控件SunAM-V1.0 音视频控件SunAM-V1.0 音视频控件SunAM-V1.0

unit bmpToAvi;

interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,
{$IFDEF VER90}
  ole2;
{$ELSE}
  ActiveX;
{$ENDIF}

type
   LONG = Longint;

   PAVIStream = Pointer;
   PAVIFile = Pointer;
   TAVIStreamList = array[0..0] of PAVIStream;
   PAVIStreamList = ^TAVIStreamList;

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

   PAVICompressOptions = ^TAVICompressOptions;
   TAVICompressOptions = packed record
    fccType: DWord; // stream type, for consistency
    fccHandler: DWord; // compressor
    dwKeyFrameEvery: DWord; // keyframe rate
    dwQuality: DWord; // compress quality 0-10,000
    dwBytesPerSecond: DWord; // bytes per second
    dwFlags: DWord; // flags... see below
    lpFormat: Pointer; // save format
    cbFormat: DWord;
    lpParms: Pointer; // compressor options
    cbParms: DWord;
    dwInterleaveEvery: DWord; // for non-video streams only
   end;
   APAVISTREAM = array[0..1] of PAVIStream;
   APAVICompressOptions = array[0..1] of PAVICompressOptions;

   TAVISaveCallback = function(i: integer): LONG; pascal;
   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 AVIMakeCompressedStream(var ppsCompressed: PAVIStream;ppsSource: PAVIStream;lpOptions: PAVICompressOptions; pclsidHandler: PCLSID): HRESULT; stdcall;
   function AVIStreamInfo(pavi: PAVIStream; var psi: TAviStreamInfo; lSize: LONG): HRESULT; stdcall;
   function AVIStreamRead(pavi: PAVIStream;lStart: LONG; lSamples: LONG; lpBuffer: Pointer; cbBuffer: LONG; plBytes: PInteger; plSamples: PInteger): HRESULT; stdcall;
   function AVIStreamStart(pavi: PAVIStream): LONG; stdcall;
   function AVIStreamLength(pavi: PAVIStream): LONG; stdcall;
   function EditStreamCopy(pavi: PAVIStream; var plStart, plLength: LONG; var ppResult: PAVIStream): HRESULT; stdcall;
   function EditStreamPaste(pavi: PAVIStream; var plPos, plLength: LONG; pstream: PAVIStream; lStart, lEnd: LONG): HRESULT; stdcall;
   function EditStreamSetInfo(pavi: PAVIStream; lpInfo: PAVIStreamInfo; cbInfo: LONG): HRESULT; stdcall;
type TFourCC = string[4];
type
   TProgressEvent = procedure(Sender: TObject; FrameCount: integer; var abort: boolean) of object;
   TBadBitmapEvent = procedure(Sender: TObject; bmp: TBitmap; InfoHeaderSize, BitsSize: integer) of object;

type
  TWriterAvi = class(TComponent)
  private
    pfile: PAVIFile;
    fHeight: integer;
    fWidth: integer;
    fStretch: boolean;
    fFrameTime: integer;
    fFilename: string;
    fWavFileName: string;
    VideoStream: PAVIStream;
    AudioStream: PAVIStream;
    fPstream, fCompStream: PAVIStream;
    fStreamInfo: TAviStreamInfo;
    fFrameCount: integer;
    fFourCC: TFourCC;
    fPixelFormat: TPixelFormat;
    //fInHeader: TBitmapInfoHeader;
    fPInInfo: PBitmapInfo;
    fInInfoSize: integer;
    AviCompressoptions: TAVICompressOptions;
    fAbort: boolean;
    fCompressionQuality: integer;
    fInitialized, fFinalized: boolean;
    fWaveFileList: TStringList;
    fCompOnFly: boolean;

    fOnProgress: TProgressEvent;
    fOnBadBitmap: TBadBitmapEvent;


    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);
    function AviSaveCallback(i: integer): LONG; pascal;
    procedure SetPixelFormat(const value: TPixelFormat);
    procedure InitStreamFormat(const bm: TBitmap);
    procedure AddAudioMod;
    procedure InternalAddFrame(const Bitmap: TBitmap; Key: boolean);
    { Private declarations }

  protected
    { Protected declarations }
  public

    Bitmaps: TList;
    TempFileName: string;
    SilenceName: string;
    constructor Create(); virtual;
    destructor Destroy; override;
    procedure Write;

    procedure InitVideo;
    procedure AddFrame(const ABmp: TBitmap);
    procedure AddStillImage(const ABmp: TBitmap; Showtime: integer);
    procedure FinalizeVideo;
    procedure WriteAvi;
    procedure Compressorlist(const List: TStrings);
    procedure SetCompression(FourCC: TFourCC);
    procedure SetCompressionQuality(q: integer);
    procedure ShowCompressorDialog(ADialogParent: TWinControl);
    procedure AddWaveFile(const filename: string; Delay: integer);

    property Aborted: boolean read fAbort;
    property OnTheFlyCompression: boolean read fCompOnFly write fCompOnFly;
    property OnBadBitmap: TBadBitmapEvent read fOnBadBitmap write fOnBadBitmap;
  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 PixelFormat: TPixelFormat read fPixelFormat write SetPixelFormat;
    property filename: string read fFilename write fFilename;
    property WavFileName: string read fWavFileName write SetWavFileName;
    property OnProgress: TProgressEvent read fOnProgress write fOnProgress;
end;


implementation
  uses MMsystem, Silence;

type
  PICINFO = ^TICINFO;
  TICINFO = packed record
    dwSize: DWord;
    fccType: DWord;
    fccHandler: DWord;
    dwFlags: DWord;
    dwVersion: DWord;
    dwVersionICM: DWord;
    szName: array[0..15] of WChar;
    szDescription: array[0..127] of WChar;
    szDriver: array[0..127] of WChar;
  end;
const
  AVICOMPRESSF_INTERLEAVE = $00000001;
  AVICOMPRESSF_DATARATE = $00000002;
  AVICOMPRESSF_KEYFRAMES = $00000004;
  AVICOMPRESSF_VALID = $00000008;
  AVIERR_OK = 0;
  AVIERR_UNSUPPORTED = HRESULT($80044065);
  AVIERR_BADFORMAT = HRESULT($80044066);
  AVIERR_MEMORY = HRESULT($80044067);
  AVIERR_INTERNAL = HRESULT($80044068);
  AVIERR_BADFLAGS = HRESULT($80044069);
  AVIERR_BADPARAM = HRESULT($8004406A);
  AVIERR_BADSIZE = HRESULT($8004406B);
  AVIERR_BADHANDLE = HRESULT($8004406C);
  AVIERR_FILEREAD = HRESULT($8004406D);
  AVIERR_FILEWRITE = HRESULT($8004406E);
  AVIERR_FILEOPEN = HRESULT($8004406F);
  AVIERR_COMPRESSOR = HRESULT($80044070);
  AVIERR_NOCOMPRESSOR = HRESULT($80044071);
  AVIERR_READONLY = HRESULT($80044072);
  AVIERR_NODATA = HRESULT($80044073);
  AVIERR_BUFFERTOOSMALL = HRESULT($80044074);
  AVIERR_CANTCOMPRESS = HRESULT($80044075);
  AVIERR_USERABORT = HRESULT($800440C6);
  AVIERR_ERROR = HRESULT($800440C7);

  streamtypeVIDEO = $73646976;
  streamtypeAUDIO = $73647561;
  AVIIF_KEYFRAME = $00000010;

  ICTYPE_VIDEO = $63646976; {vidc}
  ICMODE_COMPRESS = 1;
  ICMODE_QUERY = 4;

  ICM_USER = (DRV_USER + $0000);
  ICM_RESERVED_LOW = (DRV_USER + $1000);
  ICM_RESERVED_HIGH = (DRV_USER + $2000);
  ICM_RESERVED = ICM_RESERVED_LOW;
  ICM_COMPRESS_QUERY = (ICM_USER + 6); // query support for compress
  ICM_CONFIGURE = (ICM_RESERVED + 10); // show the configure dialog
  ICMF_CONFIGURE_QUERY = $00000001;

  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';
  function AVIMakeCompressedStream; external 'avifil32.dll' Name 'AVIMakeCompressedStream';
  function AVIStreamInfo(pavi: PAVIStream; var psi: TAviStreamInfo; lSize: LONG): HRESULT; stdcall; external 'avifil32.dll' Name 'AVIStreamInfoA';
  function AVIStreamRead(pavi: PAVIStream; lStart: LONG; lSamples: LONG; lpBuffer: Pointer; cbBuffer: LONG; plBytes: PInteger; plSamples: PInteger): HRESULT; stdcall; external 'avifil32.dll';
  function AVIStreamStart(pavi: PAVIStream): LONG; stdcall; external 'avifil32.dll';
  function AVIStreamLength(pavi: PAVIStream): LONG; stdcall; external 'avifil32.dll';
  function EditStreamCopy(pavi: PAVIStream; var plStart, plLength: LONG; var ppResult: PAVIStream): HRESULT; stdcall; external 'avifil32.dll';
  function EditStreamPaste(pavi: PAVIStream; var plPos, plLength: LONG; pstream: PAVIStream; lStart, lEnd: LONG): HRESULT; stdcall; external 'avifil32.dll';
  function EditStreamSetInfo(pavi: PAVIStream; lpInfo: PAVIStreamInfo; cbInfo: LONG): HRESULT; stdcall; external 'avifil32.dll' Name 'EditStreamSetInfoA';
  function ICInfo(fccType, fccHandler: DWord; lpicinfo: PICINFO): BOOL; stdcall; external 'MSVFW32.DLL';
  function ICOpen(fccType, fccHandler: DWord; wMode: UINT): THandle; stdcall; external 'MSVFW32.DLL';
  function ICSendMessage(hic: THandle; Msg: UINT; dw1, dw2: DWord): DWord; stdcall; external 'MSVFW32.DLL';
  function ICCompressQuery(hic: THandle; lpbiInput, lpbiOutput: PBitmapInfoHeader): DWord;
  begin
       Result := ICSendMessage(hic, ICM_COMPRESS_QUERY, DWord(lpbiInput), DWord(lpbiOutput));
  end;
  function ICGetInfo(hic: THandle; PICINFO: PICINFO; cb: DWord): DWord; stdcall; external 'MSVFW32.DLL';
  function ICClose(hic: THandle): DWord; stdcall; external 'MSVFW32.DLL';
  function ICLocate(fccType, fccHandler: DWord; lpbiIn, lpbiOut: PBitmapInfoHeader; wFlags: Word): THandle; stdcall; external 'MSVFW32.DLL';
  function ICQueryConfigure(hic: THandle): BOOL;
  begin
       Result := ICSendMessage(hic, ICM_CONFIGURE, DWord(-1), ICMF_CONFIGURE_QUERY) = 0;
  end;
  function ICConfigure(hic: THandle; HWND: HWND): DWord;
  begin
       Result := ICSendMessage(hic, ICM_CONFIGURE, HWND, 0);
  end;

//////////
constructor TWriterAvi.Create;
var
  TempDir: string;
  l: integer;
begin
  fHeight := screen.Height div 10;
  fWidth := screen.Width div 10;
  fFrameTime := 1000;
  fStretch := true;
  fFilename := '';
  Bitmaps := TList.Create;
  AVIFileInit;

  fFourCC := '';
  fPixelFormat := pf24bit;
  fAbort := false;
  fCompressionQuality := 5000;
  fCompOnFly := true;
  fWaveFileList := TStringList.Create;

  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';
end;

destructor TWriterAvi.Destroy;
var refcount: integer;
begin
  Bitmaps.Free;
  fWaveFileList.Free;
  if fPInInfo <> nil then
    FreeMem(fPInInfo);
  //any junk from a previous bomb?
  if Assigned(pfile) then
  try
    repeat
      refcount := AVIFileRelease(pfile);
    until refcount <= 0;
  except
    pfile := nil;
  end;

  if Assigned(fCompStream) then
    AVIStreamRelease(fCompStream);
  if Assigned(fPstream) then
    AVIStreamRelease(fPstream);
  if Assigned(VideoStream) then
    AVIStreamRelease(VideoStream);
  if Assigned(AudioStream) then
    AVIStreamRelease(AudioStream);

  if FileExists(TempFileName) then
    Deletefile(TempFileName);
  AVIFileExit;
  inherited;
end;

procedure TWriterAvi.Write;
var
  ExtBitmap: TBitmap;
  nStreams: integer;
  i: integer;
  Streams: APAVISTREAM;
  CompOptions: APAVICompressOptions;
  AVIERR: HRESULT;
  refcount: integer;

begin
  AudioStream := nil;
  VideoStream := nil;
  if Bitmaps.Count < 1 then
    raise Exception.Create('No bitmaps on the Bitmaps list');
  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;
    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, nil, nStreams, Streams, CompOptions);

    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;

    pfile := nil;