teevideo.pas

BCB第三方组件

{**********************************************}
{   TVideoTool component and editor dialog.    }
{   TVideoPlayerTool component.                }
{                                              }
{   Copyright (c) 2006-2007 by David Berneda   }
{**********************************************}
unit TeeVideo;
{$I TeeDefs.inc}

interface

// Idea and code based on TAviWriter components:
//
// (c) Elliott Shevin ([e-mail])
// (c) 1996 Thomas Schimming, [e-mail]
// (c) 1998,99 Anders Melander

{$IFDEF CLR}
{$UNSAFECODE ON}
{$ENDIF}

uses
  {$IFNDEF LINUX}
  Windows,
  {$ENDIF}
  SysUtils, Classes,
  {$IFDEF CLX}
  Qt, QGraphics, QControls, QForms, QDialogs, QStdCtrls, QExtCtrls, QComCtrls,
  QButtons,
  {$ELSE}
  Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls, Buttons,
  {$ENDIF}
  TeCanvas, TeEngine, Chart, TeeProCo, TeeFilters;

type
  PAVIFile = Pointer;
  PAVIStream = Pointer;

  TAviStreamInfoA = packed record
    fccType        : DWord;
    fccHandler     : DWord;
    dwFlags        : DWord;
    dwCaps         : DWord;
    wPriority      : Word;
    wLanguage      : Word;
    dwScale        : DWord;
    dwRate         : DWord;
    dwStart        : DWord;
    dwLength       : DWord;
    dwInitialFrames: DWord;
    dwSuggestedBufferSize: DWord;
    dwQuality      : DWord;
    dwSampleSize   : DWord;
    rcFrame        : TRect;
    dwEditCount    : DWord;
    dwFormatChangeCount: DWord;
    szName         : packed Array[0..63] of AnsiChar;
  end;

  PAVICompressOptions = ^TAVICompressOptions;
  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;

  TVideoTool=class(TTeeCustomTool)
  private
    FCount      : Integer;
    FDuration   : Integer;
    FFileName   : String;
    FFourCC     : String;
    FOnNewFrame : TNotifyEvent;
    FOnStart    : TNotifyEvent;
    FOnStop     : TNotifyEvent;
    FQuality    : Integer;
    FRecording  : Boolean;

    IFile    : PAVIFile;
    IStream  : TAviStreamInfoA;
    IPStream : PAVIStream;
    ICompStream : PAVIStream;
    IPInInfo : PBitmapInfo;
    AviCompressoptions: TAVICompressOptions;

    procedure AddFrame(Bitmap:TBitmap);
    procedure Clean;
    procedure CreateStream;
    procedure InitStreamFormat(Bitmap:TBitmap);
    procedure PrepareBitmapHeader(var Header:TBitmapInfoHeader);
    procedure SetCompression(const Value:String);
  protected
    Procedure ChartEvent(AEvent:TChartToolEvent); override;
    class Function GetEditorClass:String; override;
  public
    Constructor Create(AOwner:TComponent); override;
    Destructor Destroy; override;

    class Function Description:String; override;

    procedure GetCompressors(const List:TStrings);

    procedure ShowCompressorOptions(Parent:TWinControl);

    procedure StartRecording(const FileName:String);
    procedure StopRecording;

    property FrameCount:Integer read FCount;
    property IsRecording:Boolean read FRecording;
  published
    property Compression:String read FFourCC write SetCompression;
    property CompressionQuality:Integer read FQuality write FQuality default 8000;
    property FileName:String read FFileName write FFileName;
    property FrameDuration:Integer read FDuration write FDuration default 50;

    property OnNewFrame:TNotifyEvent read FOnNewFrame write FOnNewFrame;
    property OnStart:TNotifyEvent read FOnStart write FOnStart;
    property OnStop:TNotifyEvent read FOnStop write FOnStop;
  end;

  TVideoToolEditor = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    SBMsec: TScrollBar;
    CBCompress: TComboFlat;
    CBQuality: TComboFlat;
    BEdit: TButton;
    GroupBox1: TGroupBox;
    BStart: TButton;
    BStop: TButton;
    Label5: TLabel;
    EFile: TEdit;
    SpeedButton1: TSpeedButton;
    OpenDialog1: TOpenDialog;
    LFrameCap: TLabel;
    LFrame: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure SBMsecChange(Sender: TObject);
    procedure BStartClick(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure EFileChange(Sender: TObject);
    procedure BStopClick(Sender: TObject);
    procedure CBQualityChange(Sender: TObject);
    procedure CBCompressChange(Sender: TObject);
    procedure BEditClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure CBCompressDropDown(Sender: TObject);
  private
    { Private declarations }
    CompressFilled : Boolean;
    Video       : TVideoTool;
    OldNewFrame : TNotifyEvent;

    procedure SetLabelFrame;
    procedure SetupProgress;
    procedure VideoNewFrame(Sender: TObject);
  public
    { Public declarations }
  end;

  PAVIFILEINFOA = ^TAVIFILEINFOA;
  TAVIFILEINFOA = record
      dwMaxBytesPerSec      : DWORD;
      dwFlags               : DWORD;
      dwCaps                : DWORD;
      dwStreams             : DWORD;
      dwSuggestedBufferSize : DWORD;
      dwWidth               : DWORD;
      dwHeight              : DWORD;
      dwScale               : DWORD;
      dwRate                : DWORD;
      dwLength              : DWORD;
      dwEditCount           : DWORD;
      szFileType            : packed Array[0..63] of AnsiChar;
  end;

  PVOID=Pointer;

  PGetFrame = ^IGetFrame;
  IGetFrame = packed class
  public
    function GetFrame(lPos: DWORD): PVOID; virtual; stdcall; abstract;
    function _Begin(lStart, lEnd: DWORD; lRate: DWORD): HResult; virtual; stdcall; abstract;
    function _End: HResult; virtual; stdcall; abstract;
    function SetFormat(lpbi: PBITMAPINFOHEADER; lpBits: PVOID; x, y, dx, dy: Integer): HResult; virtual; stdcall; abstract;
  end;

Const
    AVIERR_OK             = 0;

    AVIERR_UNSUPPORTED    = $80044065;
    AVIERR_BADFORMAT      = $80044066;
    AVIERR_MEMORY         = $80044067;
    AVIERR_INTERNAL       = $80044068;
    AVIERR_BADFLAGS       = $80044069;
    AVIERR_BADPARAM       = $8004406A;
    AVIERR_BADSIZE        = $8004406B;
    AVIERR_BADHANDLE      = $8004406C;
    AVIERR_FILEREAD       = $8004406D;
    AVIERR_FILEWRITE      = $8004406E;
    AVIERR_FILEOPEN       = $8004406F;
    AVIERR_COMPRESSOR     = $80044070;
    AVIERR_NOCOMPRESSOR   = $80044071;
    AVIERR_READONLY       = $80044072;
    AVIERR_NODATA         = $80044073;
    AVIERR_BUFFERTOOSMALL = $80044074;
    AVIERR_CANTCOMPRESS   = $80044075;
    AVIERR_USERABORT      = $800440C6;
    AVIERR_ERROR          = $800440C7;

    StreamTypeVIDEO = $73646976; // mmioFOURCC('v', 'i', 'd', 's')
    StreamTypeAUDIO = $73647561; // mmioFOURCC('a', 'u', 'd', 's')

var
  AVIFileExit: procedure stdcall;
  AVIFileGetStream:function(pfile: PAVIFILE; var ppavi: PAVISTREAM;
                            fccType: DWORD; lParam: DWORD): HResult; stdcall;
  AVIFileInit : procedure stdcall;
  AVIFileOpen: function(var ppfile: PAVIFile; szFile: PChar; uMode: UINT;
                        lpHandler: Pointer): HRESULT; stdcall;
  AVIFileRelease:function(pfile: PAVIFile): ULONG; stdcall;
  AVIFileInfo:function(pfile: PAVIFILE; pfi: PAVIFILEINFOA; lSize: DWORD): HResult; stdcall;

  AVIStreamGetFrame:function(pg: PGETFRAME; lPos: DWORD): PVOID; stdcall;
  AVIStreamGetFrameClose:function(pg: PGETFRAME): HResult; stdcall;
  AVIStreamGetFrameOpen:function(pavi: PAVISTREAM;
                                 lpbiWanted: PBITMAPINFOHEADER): PGETFRAME; stdcall;
  AVIStreamLength:function(pavi: PAVISTREAM): DWORD; stdcall;
  AVIStreamRelease:function(pavi: PAVIStream): ULONG; stdcall;
  AVIStreamStart:function(pavi: PAVISTREAM): DWORD; stdcall;
  AVIStreamInfo:function(pavi: PAVISTREAM; var psi: TAviStreamInfoA; lSize: DWORD):DWORD; stdcall;

procedure AviCheck(const ErrorCode:HRESULT);
function InitVideoForWindows:Boolean;

implementation

{$IFNDEF CLX}
{$IFNDEF LCL}
{$R *.DFM}
{$ENDIF}
{$ELSE}
{$R *.xfm}
{$ENDIF}

uses
  MMSystem;

const
  VFW_Name='MSVFW32.DLL';
  AVIFil_Name='avifil32.dll';

  VideoBitmapFormat: TPixelFormat = pf32bit; // pf24Bit;

type
  PICINFO = ^TICINFO;
  TICINFO = packed record
    dwSize       : DWord; // sizeof(ICINFO)
    fccType      : DWord; // compressor type     'vidc' 'audc'
    fccHandler   : DWord; // compressor sub-type 'rle ' 'jpeg' 'pcm '
    dwFlags      : DWord; // flags LOWORD is type specific
    dwVersion    : DWord; // version of the driver
    dwVersionICM : DWord; // version of the ICM used
    //
    // under Win32, the driver always returns UNICODE strings.
    //
    szName       : packed Array[0..15] of WChar; // short name
    szDescription: packed Array[0..127] of WChar; // DWORD name
    szDriver     : packed Array[0..127] of WChar; // driver that contains compressor
  end;

{$IFDEF CLR}
// PENDING !
//[DllImport(AVIFil_Name, CharSet = CharSet.Ansi, EntryPoint = 'AVIFileInit')]
//procedure AVIFileInit; external;

{$ELSE}
var
  VFWHandle    : HINST;
  AVIFilHandle : HINST;

  // AVI File
  AVIFileCreateStream:function(pfile: PAVIFile; var ppavi: PAVIStream;
                               var psi: TAviStreamInfoA): HRESULT; stdcall;

  AVIStreamWrite:function(pavi: PAVIStream; lStart, lSamples: LongInt;
                     lpBuffer: Pointer; cbBuffer: LongInt; dwFlags: DWord;
                     var plSampWritten: LongInt; var plBytesWritten: LongInt): HRESULT; stdcall;

  AVIMakeCompressedStream:function(var ppsCompressed: PAVIStream; ppsSource: PAVIStream;
                     lpOptions: PAVICompressOptions; pclsidHandler: PGUID): HRESULT; stdcall;

  AVIStreamSetFormat:function(pavi: PAVIStream; lPos: LongInt; lpFormat: Pointer;
                     cbFormat: LongInt): HRESULT; stdcall;

  // Video For Windows

  ICInfo: function(fccType, fccHandler: DWord; lpicinfo: PICINFO): BOOL; stdcall;
  ICOpen: function(fccType, fccHandler: DWord; wMode: UINT): THandle; stdcall;
  ICSendMessage: function (hic: THandle; Msg: UINT; dw1, dw2: DWord): DWord; stdcall;
  ICGetInfo: function(hic: THandle; PICINFO: PICINFO; cb: DWord): DWord; stdcall;
  ICClose: function(hic: THandle): DWord; stdcall;
  ICLocate: function(fccType, fccHandler: DWord; lpbiIn, lpbiOut: PBitmapInfoHeader;
                 wFlags: Word): THandle; stdcall;

{$ENDIF}

{ TVideoTool }
procedure TVideoTool.ChartEvent(AEvent: TChartToolEvent);
begin
  inherited;

  if IsRecording and (AEvent=cteAfterDraw) then
  try
    AddFrame(TTeeCanvas3D(ParentChart.Canvas).Bitmap);
  except
    on E:Exception do
    begin
      StopRecording;
      raise;
    end;
  end;
end;

Const
  AVICodeOK = 0;
  AVIIF_KEYFRAME = $00000010;
  AVICOMPRESSF_KEYFRAMES = $00000004;
  AVICOMPRESSF_VALID = $00000008;

procedure AviCheck(const ErrorCode:HRESULT);
begin
  if ErrorCode<>AVICodeOK then
     Raise Exception.Create('AVI Error: '+IntToHex(ErrorCode,8));
end;

procedure TVideoTool.StartRecording(const FileName: String);
var tmp : Integer;
begin
  FFileName:=FileName;

  if Assigned(ParentChart) then
  begin
    AVIFileInit;

    tmp:=FileCreate(FileName);
    if tmp<>0 then
       FileClose(tmp);

    AviCheck(AVIFileOpen(IFile,PChar(FileName),OF_CREATE or OF_WRITE,nil));

    CreateStream;

    FCount:=0;

    FRecording:=True;

    if Assigned(FOnStart) then
       FOnStart(Self);
  end;
end;

procedure TVideoTool.CreateStream;
var s : String;
begin
  ZeroMemory(@IStream, SizeOf(IStream));

  IStream.dwRate:=1000;
  IStream.dwScale:=FrameDuration;
  IStream.fccType:=StreamTypeVIDEO;

  if Compression='' then
     IStream.fccHandler:=0
  else
  begin
    s:=Compression;
    IStream.fccHandler:=mmioStringToFOURCC(PChar(s), 0);
  end;

  IStream.dwQuality:=CompressionQuality;
  IStream.dwFlags:=0;
  IStream.dwSuggestedBufferSize:=0;

  IStream.rcFrame.Right:=ParentChart.Width;
  IStream.rcFrame.Bottom:=ParentChart.Height;

  AVICheck(AVIFileCreateStream(IFile, IPStream, IStream));
end;

procedure TVideoTool.StopRecording;
begin
  Clean;
  FRecording:=False;

  if Assigned(FOnStop) then
     FOnStop(Self);
end;

procedure TVideoTool.AddFrame(Bitmap:TBitmap);
var
  Samples_Written: LongInt;
  Bytes_Written: Longint;
  DIB: TDIBSection;
  DIBErr: integer;
  flag: DWord;
begin
  if FrameCount = 0 then
     InitStreamFormat(Bitmap);

  Bitmap.PixelFormat:=VideoBitmapFormat;

  FillChar(DIB, SizeOf(DIB), 0);

  DIBErr:=GetObject({$IFDEF CLX}QPixmap_hbm{$ENDIF}(Bitmap.Handle), SizeOf(DIB), @DIB);
  if DIBErr=0 then
     Raise Exception.Create('Failed to retrieve bitmap header and pixels. '+
                            'Error: ' + IntToStr(GetLastError));

  flag:= AVIIF_KEYFRAME;

  AVICheck(AVIStreamWrite(ICompStream, FrameCount, 1, DIB.dsBm.bmBits,
           DIB.dsbmih.biSizeImage, flag,
           Samples_Written, Bytes_Written));

  Inc(FCount);

  if Assigned(FOnNewFrame) then
     FOnNewFrame(Self);
end;

procedure TVideoTool.InitStreamFormat(Bitmap:TBitmap);
var
  DIB    : TDIBSection;
  Bits   : Pointer;
  DIBErr : Integer;
  S      : String;
  fInInfoSize: Integer;
begin
  Bitmap.PixelFormat:=VideoBitmapFormat;

  FillChar(DIB, SizeOf(DIB), 0);
  DIBErr:=GetObject({$IFDEF CLX}QPixmap_hbm{$ENDIF}(Bitmap.Handle), SizeOf(DIB), @DIB);
  if DIBErr=0 then
     Raise Exception.Create('Failed to retrieve bitmap header and pixels. '+
                            'Error: ' + IntToStr(GetLastError));

  if Assigned(IPInInfo) then
  begin
    FreeMem(IPInInfo);
    IPInInfo:=nil;
  end;

  fInInfoSize := SizeOf(TBitmapInfoHeader);

  if DIB.dsbmih.biBitCount <= 8 then
     fInInfoSize := fInInfoSize + SizeOf(TRGBQuad) * (1 shl DIB.dsbmih.biBitCount);

  GetMem(IPInInfo, fInInfoSize);

  GetMem(Bits, DIB.dsbmih.biSizeImage);
  try
    {$IFNDEF CLX}
    if not GetDIB(Bitmap.Handle, 0, IPInInfo^, Bits^) then
       Raise Exception.Create('Failed to retrieve bitmap info');
    {$ENDIF}
  finally
    FreeMem(Bits);
  end;

  ZeroMemory(@AviCompressoptions, SizeOf(AviCompressoptions));

  if Compression<>'' then
  begin
    S:=Compression;

    with AviCompressoptions do
    begin
      fccType := streamtypeVIDEO;
      fccHandler := mmioStringToFOURCC(PChar(S), 0);
      dwKeyFrameEvery := Round(1000/FDuration);
      dwQuality := FQuality;
      dwFlags := AVICOMPRESSF_KEYFRAMES or AVICOMPRESSF_VALID;
      lpFormat := IPInInfo;
      cbFormat := fInInfoSize;
    end;

    AVICheck(AVIMakeCompressedStream(ICompStream, IPStream, @AviCompressoptions, nil));
  end
  else
  begin
    ICompStream := IPstream;
    IPstream := nil;
  end;

  AVICheck(AVIStreamSetFormat(ICompStream, 0, IPInInfo, fInInfoSize));