3
3cs
Unregistered / Unconfirmed
GUEST, unregistred user!
能回答问题者，除500分外，请再来这里领分
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1939531
http://www.delphibbs.com/delphibbs/dispq.asp?lid=1939531
J
jingtao
Unregistered / Unconfirmed
GUEST, unregistred user!
晕..
发错了...
稍等我整理一下代码
因为是VC的
发错了...
稍等我整理一下代码
因为是VC的
J
jingtao
Unregistered / Unconfirmed
GUEST, unregistred user!
刚才试验了一下
AVI(MPEG4)也可以啊
AVI(MPEG4)也可以啊
3
3cs
Unregistered / Unconfirmed
GUEST, unregistred user!
是DIVX格式吗？我这里有一些，我试了不行，用播放MPEG1的方式来控制“原”“伴”声道
是不行的！
是不行的！
P
poppy
Unregistered / Unconfirmed
GUEST, unregistred user!
TO 3cs:mpeg4的我还没开始做,不过我有一个办法,可手头上没有mpeg4的歌,没试过行不行,你找个时间给我个压歌的工具让我压首mpeg4的歌,我自己试试行不行再说
P
poppy
Unregistered / Unconfirmed
GUEST, unregistred user!
我猜想解霸的解码器对mpeg4原/伴唱的切换处理是这样的:
左喇叭
---------/ 取其中一个喇叭 /-------------
--------------- 解码到两边的喇叭
---------/ /-------------
右喇叭
左喇叭
---------/ 取其中一个喇叭 /-------------
--------------- 解码到两边的喇叭
---------/ /-------------
右喇叭
3
3cs
Unregistered / Unconfirmed
GUEST, unregistred user!
对，但怎么做
F
firstrose
Unregistered / Unconfirmed
GUEST, unregistred user!
unit Compress;
interface
uses
Classes,Contnrs,syncobjs,Windows,variable,VideoCodec,
Dialogs,vfw,ACMConvertor;
type
VideoCompressor = class(TThread)
private
{ Private declarations }
FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
VideoCodec1:TVideoCodec;
protected
public
Constructor Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
VideoDeCompressor = class(TThread)
private
{ Private declarations }
FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
VideoCodec1:TVideoCodec;
protected
public
Constructor Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
{
AudioCompressor = class(TThread)
private
{ Private declarations }
{ FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
protected
public
constructor Create(InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
AudioDeCompressor = class(TThread)
private
{ Private declarations }
{ FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
protected
public
constructor Create(InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
}
Function QueryVideoCodec(InBMH:TBitmapinfoHeader):TBitmapinfoHeader;
Var
VC:VideoCompressor;
VDC:VideoDeCompressor;
// AC:AudioCompressor;
// ADC:AudioDeCompressor;
ACMWaveFormat:TACMWaveFormat;
implementation
Uses Main,mmsystem;
{ Important: Methods and properties of objects in VCL can only be used in a
method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure VideoCompressor.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end;
}
{ VideoCompressor }
Var
WaveFormatEx:TWaveFormatEx;
Constructor VideoCompressor.Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
begin
inherited Create(True);
FreeOnTerminate:=False;
Self.Priority:=tpLowest;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
VideoCodec1:=TVideoCodec.Create;
VideoCoDec1.Finish;
VideoCoDec1.ForceKeyFrameRate:=true;
VideoCoDec1.Init(InBMH, OutBMH, 100, 10);
VideoCoDec1.SetDataRate(1024, 1000 * 1000 div 30, 1);
If NOT VideoCoDec1.StartCompressor then
begin
ShowMessage('Can''t start compressor!');
Halt(1);
end;
end;
Destructor VideoCompressor.Destroy;
begin
VideoCoDec1.CloseCompressor;
VideoCodec1.Free;
CS.Free;
inherited Destroy;
end;
procedure VideoCompressor.Execute;
Var
p
ointer;
p1,p2:^DataBuf;
NewSize:LongWord;
Const
KeyFrame:Boolean=True;
begin
If NOT Terminated then
begin
CS.Enter;
If FQueueIn.Count>0 then
begin
p1:=FQueueIn.Pop;
p:=VideoCodec1.PackFrame(@p1^.Data,KeyFrame,NewSize);
GetMem(p2,NewSize+4);
p2^.Size:=NewSize;
Move(p^,p2^.Data,NewSize);
FQueueOut.Push(p2);
FreeMem(p1);
end;
CS.Leave;
end;
end;
{ VideoDeCompressor }
Constructor VideoDeCompressor.Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
begin
inherited Create(True);
FreeOnTerminate:=False;
Self.Priority:=tpLowest;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
VideoCodec1:=TVideoCodec.Create;
VideoCoDec1.Finish;
VideoCoDec1.ForceKeyFrameRate:=true;
VideoCoDec1.Init(InBMH, OutBMH, 100, 10);
VideoCoDec1.SetDataRate(1024, 1000 * 1000 div 30, 1);
If NOT VideoCoDec1.StartDeCompressor then
begin
ShowMessage('Can''t start decompressor!');
Halt(1);
end;
end;
Destructor VideoDeCompressor.Destroy;
begin
VideoCoDec1.CloseDeCompressor;
VideoCodec1.Free;
CS.Free;
inherited Destroy;
end;
procedure VideoDeCompressor.Execute;
Var
pointer;
p1,p2:^DataBuf;
NewSize:LongWord;
Const
KeyFrame:Boolean=True;
begin
If NOT Terminated then
begin
CS.Enter;
If FQueueIn.Count>0 then
begin
p1:=FQueueIn.Pop;
p:=VideoCodec1.UnPackFrame(@p1^.Data,KeyFrame,NewSize);
GetMem(p2,NewSize+4);
p2^.Size:=NewSize;
Move(p^,p2^.Data,NewSize);
FQueueOut.Push(p2);
FreeMem(p1);
end;
CS.Leave;
end;
end;
{
constructor AudioCompressor.Create;
begin
inherited Create(True);
FreeOnTerminate:=False;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
end;
Destructor AudioCompressor.Destroy;
begin
CS.Free;
inherited Destroy;
end;
Procedure AudioCompressor.Execute;
Var
i:LongWord;
p,p1:^DataBuf;
NewSize:LongWord;
begin
If NOT Terminated then
begin
If FQueueIn.Count>0 then
begin
p:=FQueueIn.Pop;
MainForm.ACMConvertorIn.InputBufferSize:=400;
MainForm.ACMConvertorIn.Active:=True;
For i:=1 to 20do
begin
Move(p^.Data[(i-1)*400+1],MainForm.ACMConvertorIn.BufferIn^,400);
NewSize:=MainForm.ACMConvertorIn.Convert;
GetMem(p1,NewSize+4);
p1^.Size:=NewSize;
Move(MainForm.ACMConvertorIn.BufferOut^,p1^.Data,NewSize);
FQueueOut.Push(p1);
end;
FreeMem(p);
MainForm.ACMConvertorIn.Active:=False;
end;
end;
end;
constructor AudioDeCompressor.Create;
begin
inherited Create(True);
FreeOnTerminate:=False;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
end;
Destructor AudioDeCompressor.Destroy;
begin
CS.Free;
inherited Destroy;
end;
Procedure AudioDeCompressor.Execute;
Var
p:^DataBuf;
NewSize:LongWord;
begin
If NOT Terminated then
begin
If FQueueIn.Count>0 then
begin
MainForm.ACMConvertorOut.InputBufferSize:=400;
MainForm.ACMConvertorOut.Active:=True;
p:=FQueueIn.Pop;
Move(p^.Data,MainForm.ACMConvertorOut.BufferIn^,p^.Size);
FreeMem(p);
NewSize:=MainForm.ACMConvertorOut.Convert;
GetMem(p,NewSize+4);
Move(MainForm.ACMConvertorOut.BufferOut^,p^.Data,NewSize);
MainForm.ACMConvertorOut.Active:=False;
p^.Size:=NewSize;
FQueueOut.Push(p);
end;
end;
end;
}
Function QueryVideoCodec(InBMH:TBitmapinfoHeader):TBitmapinfoHeader;
Var
i:byte;
tempicinfo:TICINFO;
temphic:hic;
tempbmh,tempbmh1:TBitmapinfoHeader;
begin
tempbmh:=InBMH;
i:=0;
While (VFW.ICInfo(ICTYPE_VIDEO,i,@tempicinfo)=True)do
begin
temphic:=ICOpen(tempicinfo.fccType,tempicinfo.fccHandler,ICMODE_QUERY);
If (temphic<>0) AND (tempicinfo.fccType=ICTYPE_VIDEO)
AND (VFW.ICCompressQuery(temphic,@tempbmh,nil)=ICERR_OK) then
begin
ICGetInfo(temphic, @tempicinfo, sizeof(tempicinfo));
If tempicinfo.szName='DIVXMPG4 V3' then
begin
DivXhIC:=temphic;
DivXICInfo:=tempicinfo;
ICCompressGetFormat(DivXhIC,@tempbmh,@tempbmh1);
end;
end;
ICClose(temphic);
Inc(i);
end;
Result:=tempbmh1;
end;
initialization
WaveFormatEx.wFormatTag:=1;
WaveFormatEx.nChannels:=1;
WaveFormatEx.nSamplesPerSec:=8000;
WaveFormatEx.nAvgBytesPerSec:=WaveFormatEx.nSamplesPerSec;
WaveFormatEx.nBlockAlign:=1;
WaveFormatEx.wBitsPerSample:=8;
WaveFormatEx.cbSize:=0;
ACMWaveFormat.Format:=WaveFormatEx;
end.
interface
uses
Classes,Contnrs,syncobjs,Windows,variable,VideoCodec,
Dialogs,vfw,ACMConvertor;
type
VideoCompressor = class(TThread)
private
{ Private declarations }
FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
VideoCodec1:TVideoCodec;
protected
public
Constructor Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
VideoDeCompressor = class(TThread)
private
{ Private declarations }
FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
VideoCodec1:TVideoCodec;
protected
public
Constructor Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
{
AudioCompressor = class(TThread)
private
{ Private declarations }
{ FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
protected
public
constructor Create(InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
AudioDeCompressor = class(TThread)
private
{ Private declarations }
{ FQueueIn,FQueueOut:TQueue;
CS:TCriticalSection;
protected
public
constructor Create(InQueue,OutQueue:TQueue);
Destructor Destroy;
override;
procedure Execute;
override;
end;
}
Function QueryVideoCodec(InBMH:TBitmapinfoHeader):TBitmapinfoHeader;
Var
VC:VideoCompressor;
VDC:VideoDeCompressor;
// AC:AudioCompressor;
// ADC:AudioDeCompressor;
ACMWaveFormat:TACMWaveFormat;
implementation
Uses Main,mmsystem;
{ Important: Methods and properties of objects in VCL can only be used in a
method called using Synchronize, for example,
Synchronize(UpdateCaption);
and UpdateCaption could look like,
procedure VideoCompressor.UpdateCaption;
begin
Form1.Caption := 'Updated in a thread';
end;
}
{ VideoCompressor }
Var
WaveFormatEx:TWaveFormatEx;
Constructor VideoCompressor.Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
begin
inherited Create(True);
FreeOnTerminate:=False;
Self.Priority:=tpLowest;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
VideoCodec1:=TVideoCodec.Create;
VideoCoDec1.Finish;
VideoCoDec1.ForceKeyFrameRate:=true;
VideoCoDec1.Init(InBMH, OutBMH, 100, 10);
VideoCoDec1.SetDataRate(1024, 1000 * 1000 div 30, 1);
If NOT VideoCoDec1.StartCompressor then
begin
ShowMessage('Can''t start compressor!');
Halt(1);
end;
end;
Destructor VideoCompressor.Destroy;
begin
VideoCoDec1.CloseCompressor;
VideoCodec1.Free;
CS.Free;
inherited Destroy;
end;
procedure VideoCompressor.Execute;
Var
p
ointer;p1,p2:^DataBuf;
NewSize:LongWord;
Const
KeyFrame:Boolean=True;
begin
If NOT Terminated then
begin
CS.Enter;
If FQueueIn.Count>0 then
begin
p1:=FQueueIn.Pop;
p:=VideoCodec1.PackFrame(@p1^.Data,KeyFrame,NewSize);
GetMem(p2,NewSize+4);
p2^.Size:=NewSize;
Move(p^,p2^.Data,NewSize);
FQueueOut.Push(p2);
FreeMem(p1);
end;
CS.Leave;
end;
end;
{ VideoDeCompressor }
Constructor VideoDeCompressor.Create(InBMH,OutBMH:TBitmapinfoHeader;InQueue,OutQueue:TQueue);
begin
inherited Create(True);
FreeOnTerminate:=False;
Self.Priority:=tpLowest;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
VideoCodec1:=TVideoCodec.Create;
VideoCoDec1.Finish;
VideoCoDec1.ForceKeyFrameRate:=true;
VideoCoDec1.Init(InBMH, OutBMH, 100, 10);
VideoCoDec1.SetDataRate(1024, 1000 * 1000 div 30, 1);
If NOT VideoCoDec1.StartDeCompressor then
begin
ShowMessage('Can''t start decompressor!');
Halt(1);
end;
end;
Destructor VideoDeCompressor.Destroy;
begin
VideoCoDec1.CloseDeCompressor;
VideoCodec1.Free;
CS.Free;
inherited Destroy;
end;
procedure VideoDeCompressor.Execute;
Var
p
ointer;p1,p2:^DataBuf;
NewSize:LongWord;
Const
KeyFrame:Boolean=True;
begin
If NOT Terminated then
begin
CS.Enter;
If FQueueIn.Count>0 then
begin
p1:=FQueueIn.Pop;
p:=VideoCodec1.UnPackFrame(@p1^.Data,KeyFrame,NewSize);
GetMem(p2,NewSize+4);
p2^.Size:=NewSize;
Move(p^,p2^.Data,NewSize);
FQueueOut.Push(p2);
FreeMem(p1);
end;
CS.Leave;
end;
end;
{
constructor AudioCompressor.Create;
begin
inherited Create(True);
FreeOnTerminate:=False;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
end;
Destructor AudioCompressor.Destroy;
begin
CS.Free;
inherited Destroy;
end;
Procedure AudioCompressor.Execute;
Var
i:LongWord;
p,p1:^DataBuf;
NewSize:LongWord;
begin
If NOT Terminated then
begin
If FQueueIn.Count>0 then
begin
p:=FQueueIn.Pop;
MainForm.ACMConvertorIn.InputBufferSize:=400;
MainForm.ACMConvertorIn.Active:=True;
For i:=1 to 20do
begin
Move(p^.Data[(i-1)*400+1],MainForm.ACMConvertorIn.BufferIn^,400);
NewSize:=MainForm.ACMConvertorIn.Convert;
GetMem(p1,NewSize+4);
p1^.Size:=NewSize;
Move(MainForm.ACMConvertorIn.BufferOut^,p1^.Data,NewSize);
FQueueOut.Push(p1);
end;
FreeMem(p);
MainForm.ACMConvertorIn.Active:=False;
end;
end;
end;
constructor AudioDeCompressor.Create;
begin
inherited Create(True);
FreeOnTerminate:=False;
FQueueIn:=InQueue;
FQueueOut:=OutQueue;
CS:=TCriticalSection.Create;
end;
Destructor AudioDeCompressor.Destroy;
begin
CS.Free;
inherited Destroy;
end;
Procedure AudioDeCompressor.Execute;
Var
p:^DataBuf;
NewSize:LongWord;
begin
If NOT Terminated then
begin
If FQueueIn.Count>0 then
begin
MainForm.ACMConvertorOut.InputBufferSize:=400;
MainForm.ACMConvertorOut.Active:=True;
p:=FQueueIn.Pop;
Move(p^.Data,MainForm.ACMConvertorOut.BufferIn^,p^.Size);
FreeMem(p);
NewSize:=MainForm.ACMConvertorOut.Convert;
GetMem(p,NewSize+4);
Move(MainForm.ACMConvertorOut.BufferOut^,p^.Data,NewSize);
MainForm.ACMConvertorOut.Active:=False;
p^.Size:=NewSize;
FQueueOut.Push(p);
end;
end;
end;
}
Function QueryVideoCodec(InBMH:TBitmapinfoHeader):TBitmapinfoHeader;
Var
i:byte;
tempicinfo:TICINFO;
temphic:hic;
tempbmh,tempbmh1:TBitmapinfoHeader;
begin
tempbmh:=InBMH;
i:=0;
While (VFW.ICInfo(ICTYPE_VIDEO,i,@tempicinfo)=True)do
begin
temphic:=ICOpen(tempicinfo.fccType,tempicinfo.fccHandler,ICMODE_QUERY);
If (temphic<>0) AND (tempicinfo.fccType=ICTYPE_VIDEO)
AND (VFW.ICCompressQuery(temphic,@tempbmh,nil)=ICERR_OK) then
begin
ICGetInfo(temphic, @tempicinfo, sizeof(tempicinfo));
If tempicinfo.szName='DIVXMPG4 V3' then
begin
DivXhIC:=temphic;
DivXICInfo:=tempicinfo;
ICCompressGetFormat(DivXhIC,@tempbmh,@tempbmh1);
end;
end;
ICClose(temphic);
Inc(i);
end;
Result:=tempbmh1;
end;
initialization
WaveFormatEx.wFormatTag:=1;
WaveFormatEx.nChannels:=1;
WaveFormatEx.nSamplesPerSec:=8000;
WaveFormatEx.nAvgBytesPerSec:=WaveFormatEx.nSamplesPerSec;
WaveFormatEx.nBlockAlign:=1;
WaveFormatEx.wBitsPerSample:=8;
WaveFormatEx.cbSize:=0;
ACMWaveFormat.Format:=WaveFormatEx;
end.
F
firstrose
Unregistered / Unconfirmed
GUEST, unregistred user!
{
Compression scheme taken from VirtualDub
Converted for Delphi by Lee_Nover - Lee_Nover@delphi-si.com 27.5.2002
}
unit VideoCoDec;
interface
uses windows, sysutils, Classes, vfw, Graphics, AviFileHandler;
const
VFW_EXT_RESULT = 1;
resourcestring
sErrorICGetInfo = 'Unable to retrieve video compressor information';
sErrorICCompressbegin
= 'Cannot start video compression'#13#10'Error code: %d';
sErrorICCompressbegin
BF = 'Cannot start video compression'#13#10'Unsupported format (Error code: %d)';
type
TFourCC = packed record
case Integer of
0: (AsCardinal: Cardinal);
1: (AsString: array[0..3] of Char);
end;
TVideoCoDec = class(TObject)
private
hICDec: Cardinal;
cv: TCompVars;
FFlags: Cardinal;
FPrevBuffer: PChar;
FBuffCompOut: PChar;
FBuffDeCompOut: PChar;
FCompressorStarted: Boolean;
FDecompressorStarted: Boolean;
FFrameNum: Integer;
FKeyRateCounter: Integer;
FForceKeyFrameRate: Boolean;
FMaxKeyFrameInterval: Cardinal;
FMaxFrameSize: Cardinal;
FMaxPackedSize: Cardinal;
FSlopSpace: Cardinal;
FCodecName: string;
FCodecDescription: string;
pConfigData: Pointer;
cbConfigData: Cardinal;
FLastError: Integer;
function InternalInit(const HasComp: Boolean = false): Boolean;
procedure SetCompVars(CompVars: TCompVars);
procedure ClearCompVars(var CompVars: TCompVars);
procedure CloseDrivers;
public
constructor Create;
destructor Destroy;
override;
function Init(CompVars: TCompVars): Boolean;
overload;
function Init(InputFormat, OutputFormat: TBitmapInfo;
const Quality, KeyRate: Integer): Boolean;
overload;
function Init(InputFormat, OutputFormat: TBitmapInfoHeader;
const Quality, KeyRate: Integer): Boolean;
overload;
function StartCompressor: Boolean;
function StartDecompressor: Boolean;
// start calls the 2 functions above
procedure Start;
procedure CloseDecompressor;
procedure CloseCompressor;
// finish calls the 2 procedures above
procedure Finish;
function ChooseCodec: Boolean;
procedure ConfigureCompressor;
procedure SetDataRate(const lDataRate, lUsPerFrame, lFrameCount: Integer);
procedure SetQuality(const Value: Integer);
function GetQuality: Integer;
function EnumCodecs(List: TStrings): Integer;
procedure DropFrame;
function PackFrame(ImageData: Pointer;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
function UnpackFrame(ImageData: Pointer;
KeyFrame: Boolean;
var Size: Cardinal): Pointer;
function CompressImage(ImageData: Pointer;
Quality: Integer;
var Size: Cardinal): HBITMAP;
function DecompressImage(ImageData: Pointer): HBITMAP;
function PackBitmap(Bitmap: TBitmap;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
function UnpackBitmap(ImageData: Pointer;
KeyFrame: Boolean;
Bitmap: TBitmap): Boolean;
function GetBitmapInfoIn: TBitmapInfo;
function GetBitmapInfoOut: TBitmapInfo;
property CompressorStarted: Boolean read FCompressorStarted;
property DecompressorStarted: Boolean read FDecompressorStarted;
property BIInput: TBitmapInfo read GetBitmapInfoIn;
property BIOutput: TBitmapInfo read GetBitmapInfoOut;
property Quality: Integer read GetQuality write SetQuality;
property ForceKeyFrameRate: Boolean read FForceKeyFrameRate write FForceKeyFrameRate;
property MaxKeyFrameRate: Cardinal read FMaxKeyFrameInterval write FMaxKeyFrameInterval;
property CodecName: string read FCodecName;
property CodecDescription: string read FCodecDescription;
property LastError: Integer read FLastError;
end;
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Integer): Integer;overload;
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Pointer): Pointer;overload;
function HasFlag(const Flags, CheckFlag: Integer): Boolean;overload;
function HasFlag(const Flags, CheckFlag: Cardinal): Boolean;overload;
function TranslateICError(ErrCode: Integer): string;
implementation
resourcestring
sVideoCoDecAbort = 'Abort';
sVideoCoDecBadBitDepth = 'Bad bit-depth';
sVideoCoDecBadFlags = 'Bad flags';
sVideoCoDecBadFormat = 'Bad format';
sVideoCoDecBadHandle = 'Bad handle';
sVideoCoDecBadImageSize = 'Bad image size';
sVideoCoDecBadParameter = 'Bad parameter';
sVideoCoDecBadSize = 'Bad size';
sVideoCoDecCanTUpdate = 'Can''t update';
sVideoCoDecDonTDraw = 'Don''t draw';
sVideoCoDecError = 'Error';
sVideoCoDecGoToKeyFrame = 'Go to KeyFrame';
sVideoCoDecInternalError = 'Internal error';
sVideoCoDecNewPalette = 'New palette';
sVideoCoDecNoError = 'No error';
sVideoCoDecNotEnoughMemory = 'Not enough memory';
sVideoCoDecStopDrawing = 'Stop drawing';
sVideoCoDecUnknownError = 'Unknown error';
sVideoCoDecUnsupportedFunctionFormat = 'Unsupported function/format';
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Integer): Integer;overload;
begin
if Condition then
Result:=ifTrue
else
Result:=ifFalse;
end;
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Pointer): Pointer;overload;
begin
if Condition then
Result:=ifTrue
else
Result:=ifFalse;
end;
function HasFlag(const Flags, CheckFlag: Integer): Boolean;overload;
begin
Result:=(Flags and CheckFlag) = CheckFlag;
end;
function HasFlag(const Flags, CheckFlag: Cardinal): Boolean;overload;
begin
Result:=(Flags and CheckFlag) = CheckFlag;
end;
function TranslateICError(ErrCode: Integer): string;
begin
case ErrCode of
ICERR_OK: Result:=sVideoCoDecNoError;
ICERR_DONTDRAW: Result:=sVideoCoDecDonTDraw;
ICERR_NEWPALETTE: Result:=sVideoCoDecNewPalette;
ICERR_GOTOKEYFRAME: Result:=sVideoCoDecGoToKeyFrame;
ICERR_STOPDRAWING: Result:=sVideoCoDecStopDrawing;
ICERR_UNSUPPORTED: Result:=sVideoCoDecUnsupportedFunctionFormat;
ICERR_BADFORMAT: Result:=sVideoCoDecBadFormat;
ICERR_MEMORY: Result:=sVideoCoDecNotEnoughMemory;
ICERR_INTERNAL: Result:=sVideoCoDecInternalError;
ICERR_BADFLAGS: Result:=sVideoCoDecBadFlags;
ICERR_BADPARAM: Result:=sVideoCoDecBadParameter;
ICERR_BADSIZE: Result:=sVideoCoDecBadSize;
ICERR_BADHANDLE: Result:=sVideoCoDecBadHandle;
ICERR_CANTUPDATE: Result:=sVideoCoDecCanTUpdate;
ICERR_ABORT: Result:=sVideoCoDecAbort;
ICERR_ERROR: Result:=sVideoCoDecError;
ICERR_BADBITDEPTH: Result:=sVideoCoDecBadBitDepth;
ICERR_BADIMAGESIZE: Result:=sVideoCoDecBadImageSize;
else
Result:=sVideoCoDecUnknownError;
end;
end;
{ TVideoCoDec }
constructor TVideoCoDec.Create;
begin
hICDec:=0;
FillChar(cv, SizeOf(cv), 0);
cv.cbSize:=SizeOf(cv);
cv.lpbiIn:=AllocMem(SizeOf(TBitmapInfo));
cv.lpbiOut:=AllocMem(SizeOf(TBitmapInfo));
FFlags:=0;
FPrevBuffer:=nil;
FBuffCompOut:=nil;
FBuffDeCompOut:=nil;
FCompressorStarted:=false;
FDecompressorStarted:=false;
FForceKeyFrameRate:=false;
pConfigData:=nil;
cbConfigData:=0;
FLastError:=ICERR_OK;
end;
destructor TVideoCoDec.Destroy;
begin
ReallocMem(FPrevBuffer, 0);
ReallocMem(FBuffCompOut, 0);
ReallocMem(FBuffDeCompOut, 0);
ReallocMem(pConfigData, 0);
// these could be freed by ICCompressFree
// but Ido
n't know what that function REALLYdo
es !
CloseDrivers;
ClearCompVars(cv);
inherited;
end;
procedure TVideoCoDec.ClearCompVars(var CompVars: TCompVars);
begin
ReallocMem(CompVars.lpbiIn, 0);
ReallocMem(CompVars.lpbiOut, 0);
ReallocMem(CompVars.lpBitsOut, 0);
ReallocMem(CompVars.lpBitsPrev, 0);
ReallocMem(CompVars.lpState, 0);
FillChar(CompVars, SizeOf(TCompVars), 0);
end;
procedure TVideoCoDec.SetCompVars(CompVars: TCompVars);
begin
cv.cbState:=CompVars.cbState;
cv.dwFlags:=CompVars.dwFlags;
cv.fccHandler:=CompVars.fccHandler;
cv.fccType:=CompVars.fccType;
if CompVars.hic > 0 then
begin
if cv.hic > 0 then
ICClose(cv.hic);
cv.hic:=CompVars.hic;
end;
cv.lDataRate:=CompVars.lDataRate;
cv.lFrame:=CompVars.lFrame;
cv.lKey:=CompVars.lKey;
cv.lKeyCount:=CompVars.lKeyCount;
cv.lQ:=CompVars.lQ;
CopyMemory(cv.lpbiIn, CompVars.lpbiIn, SizeOf(TBitmapInfo));
CopyMemory(cv.lpbiOut, CompVars.lpbiOut, SizeOf(TBitmapInfo));
end;
procedure TVideoCoDec.CloseCompressor;
begin
if cv.hic > 0 then
ICClose(cv.hic);
cv.hic:=0;
end;
procedure TVideoCoDec.CloseDecompressor;
begin
if hICDec > 0 then
ICClose(hICDec);
hICDec:=0;
end;
procedure TVideoCoDec.CloseDrivers;
begin
CloseCompressor;
CloseDecompressor;
end;
function TVideoCoDec.InternalInit(const HasComp: Boolean = false): Boolean;
var info: TICINFO;
lRealMaxPackedSize: Cardinal;
begin
FCodecName:='';
FCodecDescription:='';
CloseDecompressor;
if not HasComp then
begin
CloseCompressor;
cv.hic:=ICOpen(cv.fccType, cv.fccHandler, ICMODE_COMPRESS);
end;
hICDec:=ICOpen(cv.fccType, cv.fccHandler, ICMODE_DECOMPRESS);
FKeyRateCounter:=1;
// Retrieve compressor information.
FillChar(info, SizeOf(info), 0);
FLastError:=ICGetInfo(cv.hic, @info, SizeOf(info));
Result:=FLastError <> 0;
if not Result then
begin
// SetLastError();
exit;
end
else
FLastError:=0;
FCodecName:=info.szName;
FCodecDescription:=info.szDescription;
FFlags:=info.dwFlags;
if HasFlag(info.dwFlags, VIDCF_TEMPORAL) then
if not HasFlag(info.dwFlags, VIDCF_FASTTEMPORALC) then
// Allocate backbuffer
ReallocMem(FPrevBuffer, cv.lpbiIn^.bmiHeader.biSizeImage);
if not HasFlag(info.dwFlags, VIDCF_QUALITY) then
cv.lQ:=0;
// Allocate destination buffer
FMaxPackedSize:=ICCompressGetSize(cv.hic, @(cv.lpbiIn^.bmiHeader), @(cv.lpbiOut^.bmiHeader));
// Work around a bug in Huffyuv. Ben tried to save some memory
// and specified a "near-worst-case" bound in the codec instead
// of the actual worst case bound. Unfortunately, it's actually
// not that hard to exceed the codec's estimate with noisy
// captures -- the most common way is accidentally capturing
// static from a non-existent channel.
//
// According to the 2.1.1 comments, Huffyuv uses worst-case
// values of 24-bpp for YUY2/UYVY and 40-bpp for RGB, while the
// actual worst case values are 43 and 51. We'll compute the
// 43/51 value, and use the higher of the two.
if info.fccHandler = MKFOURCC('U', 'Y', 'F', 'H') then
begin
lRealMaxPackedSize:=cv.lpbiIn^.bmiHeader.biWidth * cv.lpbiIn^.bmiHeader.biHeight;
if (cv.lpbiIn^.bmiHeader.biCompression = BI_RGB) then
lRealMaxPackedSize:=(lRealMaxPackedSize * 51) shr 3
else
lRealMaxPackedSize:=(lRealMaxPackedSize * 43) shr 3;
if lRealMaxPackedSize > FMaxPackedSize then
FMaxPackedSize:=lRealMaxPackedSize;
end;
ReallocMem(FBuffCompOut, FMaxPackedSize);
// Save configuration state.
//
// Ordinarily, we wouldn'tdo
this, but there seems to be a bug in
// the Microsoft MPEG-4 compressor that causes it to reset its
// configuration data after a compression session. This occurs
// in all versions from V1 through V3.
//
// Stupid fscking Matrox driver returns -1!!!
cbConfigData:=ICGetStateSize(cv.hic);
if cbConfigData > 0 then
begin
ReallocMem(pConfigData, cbConfigData);
cbConfigData:=ICGetState(cv.hic, pConfigData, cbConfigData);
// As odd as this may seem, if this isn'tdo
ne, then
the Indeo5
// compressor won't allow data rate control until the next
// compression operation!
if cbConfigData <> 0 then
ICSetState(cv.hic, pConfigData, cbConfigData);
end;
FMaxFrameSize:=0;
FSlopSpace:=0;
end;
function TVideoCoDec.Init(CompVars: TCompVars): Boolean;
begin
Finish;
SetCompVars(CompVars);
Result:=InternalInit(CompVars.hic > 0);
end;
function TVideoCoDec.Init(InputFormat, OutputFormat: TBitmapInfo;
const Quality, KeyRate: Integer): Boolean;
begin
cv.lQ:=Quality;
cv.lKey:=KeyRate;
cv.lpbiIn^:=InputFormat;
cv.lpbiOut^:=OutputFormat;
cv.fccType:=MKFOURCC('V', 'I', 'D', 'C');
cv.fccHandler:=OutputFormat.bmiHeader.biCompression;
Result:=InternalInit;
end;
function TVideoCoDec.Init(InputFormat, OutputFormat: TBitmapInfoHeader;
const Quality, KeyRate: Integer): Boolean;
begin
cv.lQ:=Quality;
cv.lKey:=KeyRate;
cv.lpbiIn^.bmiHeader:=InputFormat;
cv.lpbiOut^.bmiHeader:=OutputFormat;
cv.fccType:=MKFOURCC('V', 'I', 'D', 'C');
cv.fccHandler:=OutputFormat.biCompression;
Result:=InternalInit;
end;
procedure TVideoCoDec.SetDataRate(const lDataRate, lUsPerFrame,
lFrameCount: Integer);
var ici: TICINFO;
icf: TICCOMPRESSFRAMES;
begin
if cv.hic = 0 then
exit;
if (lDataRate > 0) and HasFlag(FFlags, VIDCF_CRUNCH) then
FMaxFrameSize:=MulDiv(lDataRate, lUsPerFrame, 1000000)
else
FMaxFrameSize:=0;
// Indeo 5 needs this message for data rate clamping.
// The Morgan codec requires the message otherwise it assumes 100%
// quality
// The original version (2700) MPEG-4 V1 requires this message, period.
// V3 (DivX) gives crap if wedo
n't send it. So special case it.
ICGetInfo(cv.hic, @ici, SizeOf(ici));
FillChar(icf, SizeOf(icf), 0);
icf.dwFlags:=Cardinal(@icf.lKeyRate);
icf.lStartFrame:=0;
icf.lFrameCount:=lFrameCount;
icf.lQuality:=cv.lQ;
icf.lDataRate:=lDataRate;
// = dwRate div dwScale
icf.lKeyRate:=cv.lKey;
icf.dwRate:=1000000;
icf.dwScale:=lUsPerFrame;
FLastError:=ICSendMessage(cv.hic, ICM_COMPRESS_FRAMES_INFO, WPARAM(@icf), SizeOf(TICCOMPRESSFRAMES));
end;
procedure TVideoCoDec.Start;
begin
StartCompressor;
StartDecompressor;
end;
function TVideoCoDec.StartCompressor: Boolean;
begin
FFrameNum:=0;
FCompressorStarted:=false;
// Start compression process
FLastError:=ICCompressbegin
(cv.hic, @(cv.lpbiIn^.bmiHeader), @(cv.lpbiOut^.bmiHeader));
Result:=FLastError = ICERR_OK;
if not Result then
exit;
// Start decompression process if necessary
if Assigned(FPrevBuffer) then
begin
FLastError:=ICDecompressbegin
(cv.hic, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader));
Result:=FLastError = ICERR_OK;
if not Result then
begin
ICCompressEnd(cv.hic);
exit;
end;
end;
FCompressorStarted:=true;
end;
function TVideoCoDec.StartDecompressor: Boolean;
begin
// Start decompression process
FLastError:=ICDecompressbegin
(hICDec, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader));
FDecompressorStarted:=FLastError = ICERR_OK;
Result:=FDecompressorStarted;
end;
procedure TVideoCoDec.Finish;
begin
if FCompressorStarted then
begin
if Assigned(FPrevBuffer) then
ICDecompressEnd(cv.hic);
ICCompressEnd(cv.hic);
FCompressorStarted:=false;
// Reset MPEG-4 compressor
if (cbConfigData > 0) and Assigned(pConfigData) then
ICSetState(cv.hic, pConfigData, cbConfigData);
end;
if FDecompressorStarted then
begin
FDecompressorStarted:=false;
ICDecompressEnd(hICDec);
end;
end;
function TVideoCoDec.ChooseCodec: Boolean;
var pc: TCompVars;
begin
Result:=not FCompressorStarted;
if not Result then
exit;
pc:=cv;
pc.dwFlags:=ICMF_COMPVARS_VALID;
pc.lpbiIn:=nil;
pc.hic:=0;
pc.lpbiOut:=AllocMem(SizeOf(TBitmapInfo));
Result:=ICCompressorChoose(0, ICMF_CHOOSE_DATARATE or ICMF_CHOOSE_KEYFRAME,
nil {maybe check input format ? @(cv.lpbiIn^.bmiHeader)}, nil, @pc, nil);
// copy the original input format as it will be copied back in SetCompVars
pc.lpbiIn:=AllocMem(SizeOf(TBitmapInfo));
CopyMemory(pc.lpbiIn, cv.lpbiIn, SizeOf(TBitmapInfo));
if Result then
begin
SetCompVars(pc);
InternalInit(pc.hic > 0);
end;
ClearCompVars(pc);
end;
procedure TVideoCoDec.ConfigureCompressor;
begin
if cv.hic > 0 then
FLastError:=ICConfigure(cv.hic, 0);
end;
function TVideoCoDec.CompressImage(ImageData: Pointer;
Quality: Integer;
var Size: Cardinal): HBITMAP;
begin
Result:=ICImageCompress(cv.hic, 0, @(cv.lpbiIn^.bmiHeader), ImageData,
@(cv.lpbiOut^.bmiHeader), Quality, @Size);
end;
function TVideoCoDec.DecompressImage(ImageData: Pointer): HBITMAP;
begin
Result:=ICImageDecompress(hICDec, 0, @(cv.lpbiOut^.bmiHeader), ImageData,
@(cv.lpbiIn^.bmiHeader));
end;
procedure TVideoCoDec.DropFrame;
begin
if (cv.lKey > 0) and (FKeyRateCounter > 1) then
Dec(FKeyRateCounter);
Inc(FFrameNum);
end;
function TVideoCoDec.PackFrame(ImageData: Pointer;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
var
dwChunkId: Cardinal;
dwFlags: Cardinal;
dwFlagsIn: Cardinal;
sizeImage: Cardinal;
lAllowableFrameSize: Cardinal;
lKeyRateCounterSave: Cardinal;
bNoOutputProduced: Boolean;
begin
Size:=0;
Result:=nil;
if not FCompressorStarted then
exit;
dwChunkId:=0;
dwFlags:=0;
dwFlagsIn:=ICCOMPRESS_KEYFRAME;
lAllowableFrameSize:=0;//xFFFFFF; // yes, this is illegal according to thedo
cs (see below)
lKeyRateCounterSave:=FKeyRateCounter;
// Figure out if we should force a keyframe. If wedo
n't have any
// keyframe interval, force only the first frame. Otherwise, make
// sure that the key interval is lKeyRate or less. We count from
// the last emitted keyframe, since the compressor can opt to
// make keyframes on its own.
if FForceKeyFrameRate then
begin
if (cv.lKey = 0) then
begin
if (FFrameNum > 0) then
dwFlagsIn:=0;
end
else
begin
Dec(FKeyRateCounter);
if (FKeyRateCounter > 0) then
dwFlagsIn:=0
else
FKeyRateCounter:=cv.lKey;
end;
end
else
dwFlagsIn:=0;
// Figure out how much space to give the compressor, if we are using
// data rate stricting. If the compressor takes up less than quota
// on a frame, save the space for later frames. If the compressor
// uses too much, reduce the quota for successive frames, butdo
not
// reduce below half datarate.
if (FMaxFrameSize > 0) then
begin
lAllowableFrameSize:=FMaxFrameSize + (FSlopSpace shr 2);
if (lAllowableFrameSize < (FMaxFrameSize shr 1)) then
lAllowableFrameSize:=FMaxFrameSize shr 1;
end;
// A couple of notes:
//
// o ICSeqCompressFrame() passes 0x7FFFFFFF when data rate control
// is inactive. do
cs say 0. We pass 0x7FFFFFFF here to avoid
// a bug in the Indeo 5 QC driver, which page faults if
// keyframe interval=0 and max frame size = 0.
sizeImage:=cv.lpbiOut^.bmiHeader.biSizeImage;
// pbiOutput->bmiHeader.biSizeImage = 0;
// Compress!
if (dwFlagsIn > 0) then
dwFlags:=AVIIF_KEYFRAME;
FLastError:=ICCompress(
cv.hic, dwFlagsIn, @(cv.lpbiOut^.bmiHeader), FBuffCompOut,
@(cv.lpbiIn^.bmiHeader), ImageData, @dwChunkId, @dwFlags, FFrameNum,
IIF(FFrameNum > 0, lAllowableFrameSize, $0FFFFFF), cv.lQ,
IIF(HasFlag(dwFlagsIn, ICCOMPRESS_KEYFRAME), nil, @(cv.lpbiIn^.bmiHeader)),
IIF(HasFlag(dwFlagsIn, ICCOMPRESS_KEYFRAME), nil, FPrevBuffer));
// Special handling for DivX 5 codec:
//
// A one-byte frame starting with 0x7f should be discarded
// (lag for B-frame).
bNoOutputProduced:=false;
if (cv.lpbiOut^.bmiHeader.biCompression = MKFOURCC('0', '5', 'x', 'd')) or
(cv.lpbiOut^.bmiHeader.biCompression = MKFOURCC('0', '5', 'X', 'D')) then
begin
if (cv.lpbiOut^.bmiHeader.biSizeImage = 1) and (FBuffCompOut^ = Char($7f)) then
bNoOutputProduced:=true;
end;
// Special handling for XviD codec:
//
// Query codec for extended status.
if bNoOutputProduced then
begin
cv.lpbiOut^.bmiHeader.biSizeImage:=sizeImage;
FKeyRateCounter:=lKeyRateCounterSave;
Result:=nil;
exit;
end;
Inc(FFrameNum);
Size:=cv.lpbiOut^.bmiHeader.biSizeImage;
// If we're using a compressor with a stupid algorithm (Microsoft Video 1),
// we have to decompress the frame again to compress the next one....
if (FLastError = ICERR_OK) and Assigned(FPrevBuffer) and
((cv.lKey = 0) or (FKeyRateCounter > 1)) then
FLastError:=ICDecompress(cv.hic,
IIF(HasFlag(dwFlags, AVIIF_KEYFRAME), 0, ICDECOMPRESS_NOTKEYFRAME),
@(cv.lpbiOut^.bmiHeader), FBuffCompOut, @(cv.lpbiIn^.bmiHeader), FPrevBuffer);
cv.lpbiOut^.bmiHeader.biSizeImage:=sizeImage;
{
if (res <> ICERR_OK) then
raise Exception.Create('Video compression error');
}
if FLastError <> ICERR_OK then
begin
Result:=nil;
Size:=0;
exit;
end;
// Update quota.
if (FMaxFrameSize > 0) then
begin
FSlopSpace:=FSlopSpace + FMaxFrameSize - Size;
end;
// Was it a keyframe?
if HasFlag(dwFlags, AVIIF_KEYFRAME) then
begin
IsKeyframe:=true;
FKeyRateCounter:=cv.lKey;
end
else
begin
IsKeyframe:=false;
end;
// handle PB frames ( I263 and maybe some other codecs also)
if (Size = 8) and (FBuffCompOut^ = #0) then
Result:=PackFrame(ImageData, IsKeyFrame, Size)
else
Result:=FBuffCompOut;
end;
function TVideoCoDec.UnpackFrame(ImageData: Pointer;
KeyFrame: Boolean;
var Size: Cardinal): Pointer;
begin
Size:=cv.lpbiIn^.bmiHeader.biSizeImage;
ReallocMem(FBuffDecompOut, Size);
FLastError:=ICDecompress(hICDec,
IIF(KeyFrame, 0, ICDECOMPRESS_NOTKEYFRAME),
@(cv.lpbiOut^.bmiHeader), ImageData, @(cv.lpbiIn^.bmiHeader), FBuffDecompOut);
Result:=nil;
if (FLastError <> ICERR_OK) then
begin
Size:=0;
exit;
end;
Result:=FBuffDecompOut;
end;
function TVideoCoDec.GetBitmapInfoIn: TBitmapInfo;
begin
Result:=cv.lpbiIn^;
end;
function TVideoCoDec.GetBitmapInfoOut: TBitmapInfo;
begin
Result:=cv.lpbiOut^;
end;
function TVideoCoDec.GetQuality: Integer;
begin
Result:=cv.lQ;
end;
procedure TVideoCoDec.SetQuality(const Value: Integer);
begin
cv.lQ:=Value;
end;
function TVideoCoDec.PackBitmap(Bitmap: TBitmap;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
begin
if not Assigned(Bitmap) then
begin
Result:=nil;
Size:=0;
exit;
end
else
Result:=PackFrame(Bitmap.ScanLine[0], IsKeyFrame, Size);
end;
function TVideoCoDec.UnpackBitmap(ImageData: Pointer;
KeyFrame: Boolean;
Bitmap: TBitmap): Boolean;
var Size: Cardinal;
lpData: Pointer;
bmi: TBitmapInfo;
bmih: TBitmapInfoHeader;
usage, paintmode: Integer;
begin
Result:=Assigned(ImageData) and Assigned(Bitmap);
if not Result then
exit;
try
bmi:=BIInput;
bmih:=bmi.bmiHeader;
lpData:=UnpackFrame(ImageData, KeyFrame, Size);
Result:=Assigned(lpData) and (Size > 0);
if not Result then
exit;
usage:=IIF(bmih.biClrUsed = 0, DIB_RGB_COLORS, DIB_PAL_COLORS);
PaintMode:=IIF(KeyFrame, SRCCOPY, MERGECOPY);
with Bitmapdo
begin
Width:=bmih.biWidth;
Height:=bmih.biHeight;
Result:=StretchDIBits(Canvas.Handle, 0, 0, bmih.biWidth, bmih.biHeight,
0, 0, bmih.biWidth, bmih.biHeight, lpData, bmi, usage, paintmode) > 0;
end;
except
Result:=false;
end;
end;
// typecast the List.Objects as Cardinal to get the fccHandler code !
function TVideoCoDec.EnumCodecs(List: TStrings): Integer;
var pII: TICINFO;
c: Integer;
ok: Boolean;
fccType: TFourCC;
hIC: Cardinal;
begin
c:=0;
List.Clear;
fccType.AsString:='vidc';
ZeroMemory(@pII, SizeOf(pII));
repeat
ok:=ICInfo(fccType.AsCardinal, c, @pII);
if ok then
begin
Inc(c);
// open the compressor ..
// should get all the info with ICInfo but itdo
esn't ?!?!
// this slows the whole thing quite a bit .. about 0.5 - 1 sec !
hIC:=ICOpen(fccType.AsCardinal, pII.fccHandler, ICMODE_COMPRESS);
if hIC > 0 then
try
if ICGetInfo(hIC, @pII, SizeOf(pII)) > 0 then
List.AddObject(pII.szDescription, TObject(pII.fccHandler));
finally
ICClose(hIC);
end;
end;
until not ok;
// return the number of installed codecs
// the list can contain less codecs !
Result:=c;
end;
end.
Compression scheme taken from VirtualDub
Converted for Delphi by Lee_Nover - Lee_Nover@delphi-si.com 27.5.2002
}
unit VideoCoDec;
interface
uses windows, sysutils, Classes, vfw, Graphics, AviFileHandler;
const
VFW_EXT_RESULT = 1;
resourcestring
sErrorICGetInfo = 'Unable to retrieve video compressor information';
sErrorICCompressbegin
= 'Cannot start video compression'#13#10'Error code: %d';
sErrorICCompressbegin
BF = 'Cannot start video compression'#13#10'Unsupported format (Error code: %d)';
type
TFourCC = packed record
case Integer of
0: (AsCardinal: Cardinal);
1: (AsString: array[0..3] of Char);
end;
TVideoCoDec = class(TObject)
private
hICDec: Cardinal;
cv: TCompVars;
FFlags: Cardinal;
FPrevBuffer: PChar;
FBuffCompOut: PChar;
FBuffDeCompOut: PChar;
FCompressorStarted: Boolean;
FDecompressorStarted: Boolean;
FFrameNum: Integer;
FKeyRateCounter: Integer;
FForceKeyFrameRate: Boolean;
FMaxKeyFrameInterval: Cardinal;
FMaxFrameSize: Cardinal;
FMaxPackedSize: Cardinal;
FSlopSpace: Cardinal;
FCodecName: string;
FCodecDescription: string;
pConfigData: Pointer;
cbConfigData: Cardinal;
FLastError: Integer;
function InternalInit(const HasComp: Boolean = false): Boolean;
procedure SetCompVars(CompVars: TCompVars);
procedure ClearCompVars(var CompVars: TCompVars);
procedure CloseDrivers;
public
constructor Create;
destructor Destroy;
override;
function Init(CompVars: TCompVars): Boolean;
overload;
function Init(InputFormat, OutputFormat: TBitmapInfo;
const Quality, KeyRate: Integer): Boolean;
overload;
function Init(InputFormat, OutputFormat: TBitmapInfoHeader;
const Quality, KeyRate: Integer): Boolean;
overload;
function StartCompressor: Boolean;
function StartDecompressor: Boolean;
// start calls the 2 functions above
procedure Start;
procedure CloseDecompressor;
procedure CloseCompressor;
// finish calls the 2 procedures above
procedure Finish;
function ChooseCodec: Boolean;
procedure ConfigureCompressor;
procedure SetDataRate(const lDataRate, lUsPerFrame, lFrameCount: Integer);
procedure SetQuality(const Value: Integer);
function GetQuality: Integer;
function EnumCodecs(List: TStrings): Integer;
procedure DropFrame;
function PackFrame(ImageData: Pointer;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
function UnpackFrame(ImageData: Pointer;
KeyFrame: Boolean;
var Size: Cardinal): Pointer;
function CompressImage(ImageData: Pointer;
Quality: Integer;
var Size: Cardinal): HBITMAP;
function DecompressImage(ImageData: Pointer): HBITMAP;
function PackBitmap(Bitmap: TBitmap;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
function UnpackBitmap(ImageData: Pointer;
KeyFrame: Boolean;
Bitmap: TBitmap): Boolean;
function GetBitmapInfoIn: TBitmapInfo;
function GetBitmapInfoOut: TBitmapInfo;
property CompressorStarted: Boolean read FCompressorStarted;
property DecompressorStarted: Boolean read FDecompressorStarted;
property BIInput: TBitmapInfo read GetBitmapInfoIn;
property BIOutput: TBitmapInfo read GetBitmapInfoOut;
property Quality: Integer read GetQuality write SetQuality;
property ForceKeyFrameRate: Boolean read FForceKeyFrameRate write FForceKeyFrameRate;
property MaxKeyFrameRate: Cardinal read FMaxKeyFrameInterval write FMaxKeyFrameInterval;
property CodecName: string read FCodecName;
property CodecDescription: string read FCodecDescription;
property LastError: Integer read FLastError;
end;
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Integer): Integer;overload;
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Pointer): Pointer;overload;
function HasFlag(const Flags, CheckFlag: Integer): Boolean;overload;
function HasFlag(const Flags, CheckFlag: Cardinal): Boolean;overload;
function TranslateICError(ErrCode: Integer): string;
implementation
resourcestring
sVideoCoDecAbort = 'Abort';
sVideoCoDecBadBitDepth = 'Bad bit-depth';
sVideoCoDecBadFlags = 'Bad flags';
sVideoCoDecBadFormat = 'Bad format';
sVideoCoDecBadHandle = 'Bad handle';
sVideoCoDecBadImageSize = 'Bad image size';
sVideoCoDecBadParameter = 'Bad parameter';
sVideoCoDecBadSize = 'Bad size';
sVideoCoDecCanTUpdate = 'Can''t update';
sVideoCoDecDonTDraw = 'Don''t draw';
sVideoCoDecError = 'Error';
sVideoCoDecGoToKeyFrame = 'Go to KeyFrame';
sVideoCoDecInternalError = 'Internal error';
sVideoCoDecNewPalette = 'New palette';
sVideoCoDecNoError = 'No error';
sVideoCoDecNotEnoughMemory = 'Not enough memory';
sVideoCoDecStopDrawing = 'Stop drawing';
sVideoCoDecUnknownError = 'Unknown error';
sVideoCoDecUnsupportedFunctionFormat = 'Unsupported function/format';
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Integer): Integer;overload;
begin
if Condition then
Result:=ifTrue
else
Result:=ifFalse;
end;
function IIF(const Condition: Boolean;
const ifTrue, ifFalse: Pointer): Pointer;overload;
begin
if Condition then
Result:=ifTrue
else
Result:=ifFalse;
end;
function HasFlag(const Flags, CheckFlag: Integer): Boolean;overload;
begin
Result:=(Flags and CheckFlag) = CheckFlag;
end;
function HasFlag(const Flags, CheckFlag: Cardinal): Boolean;overload;
begin
Result:=(Flags and CheckFlag) = CheckFlag;
end;
function TranslateICError(ErrCode: Integer): string;
begin
case ErrCode of
ICERR_OK: Result:=sVideoCoDecNoError;
ICERR_DONTDRAW: Result:=sVideoCoDecDonTDraw;
ICERR_NEWPALETTE: Result:=sVideoCoDecNewPalette;
ICERR_GOTOKEYFRAME: Result:=sVideoCoDecGoToKeyFrame;
ICERR_STOPDRAWING: Result:=sVideoCoDecStopDrawing;
ICERR_UNSUPPORTED: Result:=sVideoCoDecUnsupportedFunctionFormat;
ICERR_BADFORMAT: Result:=sVideoCoDecBadFormat;
ICERR_MEMORY: Result:=sVideoCoDecNotEnoughMemory;
ICERR_INTERNAL: Result:=sVideoCoDecInternalError;
ICERR_BADFLAGS: Result:=sVideoCoDecBadFlags;
ICERR_BADPARAM: Result:=sVideoCoDecBadParameter;
ICERR_BADSIZE: Result:=sVideoCoDecBadSize;
ICERR_BADHANDLE: Result:=sVideoCoDecBadHandle;
ICERR_CANTUPDATE: Result:=sVideoCoDecCanTUpdate;
ICERR_ABORT: Result:=sVideoCoDecAbort;
ICERR_ERROR: Result:=sVideoCoDecError;
ICERR_BADBITDEPTH: Result:=sVideoCoDecBadBitDepth;
ICERR_BADIMAGESIZE: Result:=sVideoCoDecBadImageSize;
else
Result:=sVideoCoDecUnknownError;
end;
end;
{ TVideoCoDec }
constructor TVideoCoDec.Create;
begin
hICDec:=0;
FillChar(cv, SizeOf(cv), 0);
cv.cbSize:=SizeOf(cv);
cv.lpbiIn:=AllocMem(SizeOf(TBitmapInfo));
cv.lpbiOut:=AllocMem(SizeOf(TBitmapInfo));
FFlags:=0;
FPrevBuffer:=nil;
FBuffCompOut:=nil;
FBuffDeCompOut:=nil;
FCompressorStarted:=false;
FDecompressorStarted:=false;
FForceKeyFrameRate:=false;
pConfigData:=nil;
cbConfigData:=0;
FLastError:=ICERR_OK;
end;
destructor TVideoCoDec.Destroy;
begin
ReallocMem(FPrevBuffer, 0);
ReallocMem(FBuffCompOut, 0);
ReallocMem(FBuffDeCompOut, 0);
ReallocMem(pConfigData, 0);
// these could be freed by ICCompressFree
// but Ido
n't know what that function REALLYdo
es !
CloseDrivers;
ClearCompVars(cv);
inherited;
end;
procedure TVideoCoDec.ClearCompVars(var CompVars: TCompVars);
begin
ReallocMem(CompVars.lpbiIn, 0);
ReallocMem(CompVars.lpbiOut, 0);
ReallocMem(CompVars.lpBitsOut, 0);
ReallocMem(CompVars.lpBitsPrev, 0);
ReallocMem(CompVars.lpState, 0);
FillChar(CompVars, SizeOf(TCompVars), 0);
end;
procedure TVideoCoDec.SetCompVars(CompVars: TCompVars);
begin
cv.cbState:=CompVars.cbState;
cv.dwFlags:=CompVars.dwFlags;
cv.fccHandler:=CompVars.fccHandler;
cv.fccType:=CompVars.fccType;
if CompVars.hic > 0 then
begin
if cv.hic > 0 then
ICClose(cv.hic);
cv.hic:=CompVars.hic;
end;
cv.lDataRate:=CompVars.lDataRate;
cv.lFrame:=CompVars.lFrame;
cv.lKey:=CompVars.lKey;
cv.lKeyCount:=CompVars.lKeyCount;
cv.lQ:=CompVars.lQ;
CopyMemory(cv.lpbiIn, CompVars.lpbiIn, SizeOf(TBitmapInfo));
CopyMemory(cv.lpbiOut, CompVars.lpbiOut, SizeOf(TBitmapInfo));
end;
procedure TVideoCoDec.CloseCompressor;
begin
if cv.hic > 0 then
ICClose(cv.hic);
cv.hic:=0;
end;
procedure TVideoCoDec.CloseDecompressor;
begin
if hICDec > 0 then
ICClose(hICDec);
hICDec:=0;
end;
procedure TVideoCoDec.CloseDrivers;
begin
CloseCompressor;
CloseDecompressor;
end;
function TVideoCoDec.InternalInit(const HasComp: Boolean = false): Boolean;
var info: TICINFO;
lRealMaxPackedSize: Cardinal;
begin
FCodecName:='';
FCodecDescription:='';
CloseDecompressor;
if not HasComp then
begin
CloseCompressor;
cv.hic:=ICOpen(cv.fccType, cv.fccHandler, ICMODE_COMPRESS);
end;
hICDec:=ICOpen(cv.fccType, cv.fccHandler, ICMODE_DECOMPRESS);
FKeyRateCounter:=1;
// Retrieve compressor information.
FillChar(info, SizeOf(info), 0);
FLastError:=ICGetInfo(cv.hic, @info, SizeOf(info));
Result:=FLastError <> 0;
if not Result then
begin
// SetLastError();
exit;
end
else
FLastError:=0;
FCodecName:=info.szName;
FCodecDescription:=info.szDescription;
FFlags:=info.dwFlags;
if HasFlag(info.dwFlags, VIDCF_TEMPORAL) then
if not HasFlag(info.dwFlags, VIDCF_FASTTEMPORALC) then
// Allocate backbuffer
ReallocMem(FPrevBuffer, cv.lpbiIn^.bmiHeader.biSizeImage);
if not HasFlag(info.dwFlags, VIDCF_QUALITY) then
cv.lQ:=0;
// Allocate destination buffer
FMaxPackedSize:=ICCompressGetSize(cv.hic, @(cv.lpbiIn^.bmiHeader), @(cv.lpbiOut^.bmiHeader));
// Work around a bug in Huffyuv. Ben tried to save some memory
// and specified a "near-worst-case" bound in the codec instead
// of the actual worst case bound. Unfortunately, it's actually
// not that hard to exceed the codec's estimate with noisy
// captures -- the most common way is accidentally capturing
// static from a non-existent channel.
//
// According to the 2.1.1 comments, Huffyuv uses worst-case
// values of 24-bpp for YUY2/UYVY and 40-bpp for RGB, while the
// actual worst case values are 43 and 51. We'll compute the
// 43/51 value, and use the higher of the two.
if info.fccHandler = MKFOURCC('U', 'Y', 'F', 'H') then
begin
lRealMaxPackedSize:=cv.lpbiIn^.bmiHeader.biWidth * cv.lpbiIn^.bmiHeader.biHeight;
if (cv.lpbiIn^.bmiHeader.biCompression = BI_RGB) then
lRealMaxPackedSize:=(lRealMaxPackedSize * 51) shr 3
else
lRealMaxPackedSize:=(lRealMaxPackedSize * 43) shr 3;
if lRealMaxPackedSize > FMaxPackedSize then
FMaxPackedSize:=lRealMaxPackedSize;
end;
ReallocMem(FBuffCompOut, FMaxPackedSize);
// Save configuration state.
//
// Ordinarily, we wouldn'tdo
this, but there seems to be a bug in
// the Microsoft MPEG-4 compressor that causes it to reset its
// configuration data after a compression session. This occurs
// in all versions from V1 through V3.
//
// Stupid fscking Matrox driver returns -1!!!
cbConfigData:=ICGetStateSize(cv.hic);
if cbConfigData > 0 then
begin
ReallocMem(pConfigData, cbConfigData);
cbConfigData:=ICGetState(cv.hic, pConfigData, cbConfigData);
// As odd as this may seem, if this isn'tdo
ne, then
the Indeo5
// compressor won't allow data rate control until the next
// compression operation!
if cbConfigData <> 0 then
ICSetState(cv.hic, pConfigData, cbConfigData);
end;
FMaxFrameSize:=0;
FSlopSpace:=0;
end;
function TVideoCoDec.Init(CompVars: TCompVars): Boolean;
begin
Finish;
SetCompVars(CompVars);
Result:=InternalInit(CompVars.hic > 0);
end;
function TVideoCoDec.Init(InputFormat, OutputFormat: TBitmapInfo;
const Quality, KeyRate: Integer): Boolean;
begin
cv.lQ:=Quality;
cv.lKey:=KeyRate;
cv.lpbiIn^:=InputFormat;
cv.lpbiOut^:=OutputFormat;
cv.fccType:=MKFOURCC('V', 'I', 'D', 'C');
cv.fccHandler:=OutputFormat.bmiHeader.biCompression;
Result:=InternalInit;
end;
function TVideoCoDec.Init(InputFormat, OutputFormat: TBitmapInfoHeader;
const Quality, KeyRate: Integer): Boolean;
begin
cv.lQ:=Quality;
cv.lKey:=KeyRate;
cv.lpbiIn^.bmiHeader:=InputFormat;
cv.lpbiOut^.bmiHeader:=OutputFormat;
cv.fccType:=MKFOURCC('V', 'I', 'D', 'C');
cv.fccHandler:=OutputFormat.biCompression;
Result:=InternalInit;
end;
procedure TVideoCoDec.SetDataRate(const lDataRate, lUsPerFrame,
lFrameCount: Integer);
var ici: TICINFO;
icf: TICCOMPRESSFRAMES;
begin
if cv.hic = 0 then
exit;
if (lDataRate > 0) and HasFlag(FFlags, VIDCF_CRUNCH) then
FMaxFrameSize:=MulDiv(lDataRate, lUsPerFrame, 1000000)
else
FMaxFrameSize:=0;
// Indeo 5 needs this message for data rate clamping.
// The Morgan codec requires the message otherwise it assumes 100%
// quality
// The original version (2700) MPEG-4 V1 requires this message, period.
// V3 (DivX) gives crap if wedo
n't send it. So special case it.
ICGetInfo(cv.hic, @ici, SizeOf(ici));
FillChar(icf, SizeOf(icf), 0);
icf.dwFlags:=Cardinal(@icf.lKeyRate);
icf.lStartFrame:=0;
icf.lFrameCount:=lFrameCount;
icf.lQuality:=cv.lQ;
icf.lDataRate:=lDataRate;
// = dwRate div dwScale
icf.lKeyRate:=cv.lKey;
icf.dwRate:=1000000;
icf.dwScale:=lUsPerFrame;
FLastError:=ICSendMessage(cv.hic, ICM_COMPRESS_FRAMES_INFO, WPARAM(@icf), SizeOf(TICCOMPRESSFRAMES));
end;
procedure TVideoCoDec.Start;
begin
StartCompressor;
StartDecompressor;
end;
function TVideoCoDec.StartCompressor: Boolean;
begin
FFrameNum:=0;
FCompressorStarted:=false;
// Start compression process
FLastError:=ICCompressbegin
(cv.hic, @(cv.lpbiIn^.bmiHeader), @(cv.lpbiOut^.bmiHeader));
Result:=FLastError = ICERR_OK;
if not Result then
exit;
// Start decompression process if necessary
if Assigned(FPrevBuffer) then
begin
FLastError:=ICDecompressbegin
(cv.hic, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader));
Result:=FLastError = ICERR_OK;
if not Result then
begin
ICCompressEnd(cv.hic);
exit;
end;
end;
FCompressorStarted:=true;
end;
function TVideoCoDec.StartDecompressor: Boolean;
begin
// Start decompression process
FLastError:=ICDecompressbegin
(hICDec, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader));
FDecompressorStarted:=FLastError = ICERR_OK;
Result:=FDecompressorStarted;
end;
procedure TVideoCoDec.Finish;
begin
if FCompressorStarted then
begin
if Assigned(FPrevBuffer) then
ICDecompressEnd(cv.hic);
ICCompressEnd(cv.hic);
FCompressorStarted:=false;
// Reset MPEG-4 compressor
if (cbConfigData > 0) and Assigned(pConfigData) then
ICSetState(cv.hic, pConfigData, cbConfigData);
end;
if FDecompressorStarted then
begin
FDecompressorStarted:=false;
ICDecompressEnd(hICDec);
end;
end;
function TVideoCoDec.ChooseCodec: Boolean;
var pc: TCompVars;
begin
Result:=not FCompressorStarted;
if not Result then
exit;
pc:=cv;
pc.dwFlags:=ICMF_COMPVARS_VALID;
pc.lpbiIn:=nil;
pc.hic:=0;
pc.lpbiOut:=AllocMem(SizeOf(TBitmapInfo));
Result:=ICCompressorChoose(0, ICMF_CHOOSE_DATARATE or ICMF_CHOOSE_KEYFRAME,
nil {maybe check input format ? @(cv.lpbiIn^.bmiHeader)}, nil, @pc, nil);
// copy the original input format as it will be copied back in SetCompVars
pc.lpbiIn:=AllocMem(SizeOf(TBitmapInfo));
CopyMemory(pc.lpbiIn, cv.lpbiIn, SizeOf(TBitmapInfo));
if Result then
begin
SetCompVars(pc);
InternalInit(pc.hic > 0);
end;
ClearCompVars(pc);
end;
procedure TVideoCoDec.ConfigureCompressor;
begin
if cv.hic > 0 then
FLastError:=ICConfigure(cv.hic, 0);
end;
function TVideoCoDec.CompressImage(ImageData: Pointer;
Quality: Integer;
var Size: Cardinal): HBITMAP;
begin
Result:=ICImageCompress(cv.hic, 0, @(cv.lpbiIn^.bmiHeader), ImageData,
@(cv.lpbiOut^.bmiHeader), Quality, @Size);
end;
function TVideoCoDec.DecompressImage(ImageData: Pointer): HBITMAP;
begin
Result:=ICImageDecompress(hICDec, 0, @(cv.lpbiOut^.bmiHeader), ImageData,
@(cv.lpbiIn^.bmiHeader));
end;
procedure TVideoCoDec.DropFrame;
begin
if (cv.lKey > 0) and (FKeyRateCounter > 1) then
Dec(FKeyRateCounter);
Inc(FFrameNum);
end;
function TVideoCoDec.PackFrame(ImageData: Pointer;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
var
dwChunkId: Cardinal;
dwFlags: Cardinal;
dwFlagsIn: Cardinal;
sizeImage: Cardinal;
lAllowableFrameSize: Cardinal;
lKeyRateCounterSave: Cardinal;
bNoOutputProduced: Boolean;
begin
Size:=0;
Result:=nil;
if not FCompressorStarted then
exit;
dwChunkId:=0;
dwFlags:=0;
dwFlagsIn:=ICCOMPRESS_KEYFRAME;
lAllowableFrameSize:=0;//xFFFFFF; // yes, this is illegal according to thedo
cs (see below)
lKeyRateCounterSave:=FKeyRateCounter;
// Figure out if we should force a keyframe. If wedo
n't have any
// keyframe interval, force only the first frame. Otherwise, make
// sure that the key interval is lKeyRate or less. We count from
// the last emitted keyframe, since the compressor can opt to
// make keyframes on its own.
if FForceKeyFrameRate then
begin
if (cv.lKey = 0) then
begin
if (FFrameNum > 0) then
dwFlagsIn:=0;
end
else
begin
Dec(FKeyRateCounter);
if (FKeyRateCounter > 0) then
dwFlagsIn:=0
else
FKeyRateCounter:=cv.lKey;
end;
end
else
dwFlagsIn:=0;
// Figure out how much space to give the compressor, if we are using
// data rate stricting. If the compressor takes up less than quota
// on a frame, save the space for later frames. If the compressor
// uses too much, reduce the quota for successive frames, butdo
not
// reduce below half datarate.
if (FMaxFrameSize > 0) then
begin
lAllowableFrameSize:=FMaxFrameSize + (FSlopSpace shr 2);
if (lAllowableFrameSize < (FMaxFrameSize shr 1)) then
lAllowableFrameSize:=FMaxFrameSize shr 1;
end;
// A couple of notes:
//
// o ICSeqCompressFrame() passes 0x7FFFFFFF when data rate control
// is inactive. do
cs say 0. We pass 0x7FFFFFFF here to avoid
// a bug in the Indeo 5 QC driver, which page faults if
// keyframe interval=0 and max frame size = 0.
sizeImage:=cv.lpbiOut^.bmiHeader.biSizeImage;
// pbiOutput->bmiHeader.biSizeImage = 0;
// Compress!
if (dwFlagsIn > 0) then
dwFlags:=AVIIF_KEYFRAME;
FLastError:=ICCompress(
cv.hic, dwFlagsIn, @(cv.lpbiOut^.bmiHeader), FBuffCompOut,
@(cv.lpbiIn^.bmiHeader), ImageData, @dwChunkId, @dwFlags, FFrameNum,
IIF(FFrameNum > 0, lAllowableFrameSize, $0FFFFFF), cv.lQ,
IIF(HasFlag(dwFlagsIn, ICCOMPRESS_KEYFRAME), nil, @(cv.lpbiIn^.bmiHeader)),
IIF(HasFlag(dwFlagsIn, ICCOMPRESS_KEYFRAME), nil, FPrevBuffer));
// Special handling for DivX 5 codec:
//
// A one-byte frame starting with 0x7f should be discarded
// (lag for B-frame).
bNoOutputProduced:=false;
if (cv.lpbiOut^.bmiHeader.biCompression = MKFOURCC('0', '5', 'x', 'd')) or
(cv.lpbiOut^.bmiHeader.biCompression = MKFOURCC('0', '5', 'X', 'D')) then
begin
if (cv.lpbiOut^.bmiHeader.biSizeImage = 1) and (FBuffCompOut^ = Char($7f)) then
bNoOutputProduced:=true;
end;
// Special handling for XviD codec:
//
// Query codec for extended status.
if bNoOutputProduced then
begin
cv.lpbiOut^.bmiHeader.biSizeImage:=sizeImage;
FKeyRateCounter:=lKeyRateCounterSave;
Result:=nil;
exit;
end;
Inc(FFrameNum);
Size:=cv.lpbiOut^.bmiHeader.biSizeImage;
// If we're using a compressor with a stupid algorithm (Microsoft Video 1),
// we have to decompress the frame again to compress the next one....
if (FLastError = ICERR_OK) and Assigned(FPrevBuffer) and
((cv.lKey = 0) or (FKeyRateCounter > 1)) then
FLastError:=ICDecompress(cv.hic,
IIF(HasFlag(dwFlags, AVIIF_KEYFRAME), 0, ICDECOMPRESS_NOTKEYFRAME),
@(cv.lpbiOut^.bmiHeader), FBuffCompOut, @(cv.lpbiIn^.bmiHeader), FPrevBuffer);
cv.lpbiOut^.bmiHeader.biSizeImage:=sizeImage;
{
if (res <> ICERR_OK) then
raise Exception.Create('Video compression error');
}
if FLastError <> ICERR_OK then
begin
Result:=nil;
Size:=0;
exit;
end;
// Update quota.
if (FMaxFrameSize > 0) then
begin
FSlopSpace:=FSlopSpace + FMaxFrameSize - Size;
end;
// Was it a keyframe?
if HasFlag(dwFlags, AVIIF_KEYFRAME) then
begin
IsKeyframe:=true;
FKeyRateCounter:=cv.lKey;
end
else
begin
IsKeyframe:=false;
end;
// handle PB frames ( I263 and maybe some other codecs also)
if (Size = 8) and (FBuffCompOut^ = #0) then
Result:=PackFrame(ImageData, IsKeyFrame, Size)
else
Result:=FBuffCompOut;
end;
function TVideoCoDec.UnpackFrame(ImageData: Pointer;
KeyFrame: Boolean;
var Size: Cardinal): Pointer;
begin
Size:=cv.lpbiIn^.bmiHeader.biSizeImage;
ReallocMem(FBuffDecompOut, Size);
FLastError:=ICDecompress(hICDec,
IIF(KeyFrame, 0, ICDECOMPRESS_NOTKEYFRAME),
@(cv.lpbiOut^.bmiHeader), ImageData, @(cv.lpbiIn^.bmiHeader), FBuffDecompOut);
Result:=nil;
if (FLastError <> ICERR_OK) then
begin
Size:=0;
exit;
end;
Result:=FBuffDecompOut;
end;
function TVideoCoDec.GetBitmapInfoIn: TBitmapInfo;
begin
Result:=cv.lpbiIn^;
end;
function TVideoCoDec.GetBitmapInfoOut: TBitmapInfo;
begin
Result:=cv.lpbiOut^;
end;
function TVideoCoDec.GetQuality: Integer;
begin
Result:=cv.lQ;
end;
procedure TVideoCoDec.SetQuality(const Value: Integer);
begin
cv.lQ:=Value;
end;
function TVideoCoDec.PackBitmap(Bitmap: TBitmap;
var IsKeyFrame: Boolean;
var Size: Cardinal): Pointer;
begin
if not Assigned(Bitmap) then
begin
Result:=nil;
Size:=0;
exit;
end
else
Result:=PackFrame(Bitmap.ScanLine[0], IsKeyFrame, Size);
end;
function TVideoCoDec.UnpackBitmap(ImageData: Pointer;
KeyFrame: Boolean;
Bitmap: TBitmap): Boolean;
var Size: Cardinal;
lpData: Pointer;
bmi: TBitmapInfo;
bmih: TBitmapInfoHeader;
usage, paintmode: Integer;
begin
Result:=Assigned(ImageData) and Assigned(Bitmap);
if not Result then
exit;
try
bmi:=BIInput;
bmih:=bmi.bmiHeader;
lpData:=UnpackFrame(ImageData, KeyFrame, Size);
Result:=Assigned(lpData) and (Size > 0);
if not Result then
exit;
usage:=IIF(bmih.biClrUsed = 0, DIB_RGB_COLORS, DIB_PAL_COLORS);
PaintMode:=IIF(KeyFrame, SRCCOPY, MERGECOPY);
with Bitmapdo
begin
Width:=bmih.biWidth;
Height:=bmih.biHeight;
Result:=StretchDIBits(Canvas.Handle, 0, 0, bmih.biWidth, bmih.biHeight,
0, 0, bmih.biWidth, bmih.biHeight, lpData, bmi, usage, paintmode) > 0;
end;
except
Result:=false;
end;
end;
// typecast the List.Objects as Cardinal to get the fccHandler code !
function TVideoCoDec.EnumCodecs(List: TStrings): Integer;
var pII: TICINFO;
c: Integer;
ok: Boolean;
fccType: TFourCC;
hIC: Cardinal;
begin
c:=0;
List.Clear;
fccType.AsString:='vidc';
ZeroMemory(@pII, SizeOf(pII));
repeat
ok:=ICInfo(fccType.AsCardinal, c, @pII);
if ok then
begin
Inc(c);
// open the compressor ..
// should get all the info with ICInfo but itdo
esn't ?!?!
// this slows the whole thing quite a bit .. about 0.5 - 1 sec !
hIC:=ICOpen(fccType.AsCardinal, pII.fccHandler, ICMODE_COMPRESS);
if hIC > 0 then
try
if ICGetInfo(hIC, @pII, SizeOf(pII)) > 0 then
List.AddObject(pII.szDescription, TObject(pII.fccHandler));
finally
ICClose(hIC);
end;
end;
until not ok;
// return the number of installed codecs
// the list can contain less codecs !
Result:=c;
end;
end.
F
firstrose
Unregistered / Unconfirmed
GUEST, unregistred user!
unit AviFileHandler;
interface
uses Windows, Classes, sysutils, vfw, mmsystem, graphics;
type
TFourCC = packed record
case Integer of
0: (AsCardinal: Cardinal);
1: (AsString: array[0..3] of Char);
end;
TAVIBaseStream = class(TObject)
private
FName: string;
FStream: IAVIStream;
FStreamInfo: TAVIStreamInfoW;
FAviFile: IAVIFile;
protected
FSamples: Cardinal;
public
constructor Create(AviFile: IAVIFile;
StreamInfo: TAVIStreamInfoW);
virtual;
destructor Destroy;
override;
function WriteSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
function AddSample(cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
function ReadSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer): Boolean;
function DeleteSamples(Index, Count: Cardinal): Integer;
procedure SetName(Value: string);
// returns the FOURCC code of the type
function GetStreamType: Cardinal;
property Name: string read FName write SetName;
// streams name ... just to eat more memory
property Stream: IAVIStream read FStream;
// direct acces to the stream object if needed
property StreamType: Cardinal read GetStreamType;
// the streams type (streamtypeVIDEO/AUDIO, ...)
property Samples: Cardinal read FSamples;
// number of samples in the stream
end;
TAVIVideoStream = class(TAVIBaseStream)
private
FFormat: TBitmapInfoHeader;
function Samples: Cardinal;
public
constructor Create(AviFile: IAVIFile;
AFormat: TBitmapInfoHeader;
FrameRate: Integer;
fccHandler: Cardinal);
reintroduce;
destructor Destroy;
override;
function InsertFrame(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
overload;
function InsertFrame(Index: Integer;
Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
overload;
function AddFrame(cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
overload;
function AddFrame(Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
overload;
function DeleteFrames(Index, Count: Cardinal): Integer;
property Frames: Cardinal read Samples;
end;
TAVIAudioStream = class(TAVIBaseStream)
private
FFormat: TWaveFormatEx;
public
constructor Create(AviFile: IAVIFile;
AFormat: TWaveFormatEx);
reintroduce;
destructor Destroy;
override;
end;
TAviStreamList = class(TList)
private
function Get(Index: Integer): TAVIBaseStream;
procedure Put(Index: Integer;
Stream: TAVIBaseStream);
protected
procedure Notify(Ptr: Pointer;
Action: TListNotification);
override;
public
function Insert(Index: Integer;
Stream: TAVIBaseStream): Integer;
function Add(Stream: TAVIBaseStream): Integer;
property Items[Index: Integer]: TAVIBaseStream read Get write Put;
default;
end;
TAviFileHandler = class(TObject)
private
FAviFile: IAVIFile;
FStreams: TAviStreamList;
public
constructor Create(FileName: string);
destructor Destroy;
override;
function FirstVideoStream: TAVIVideoStream;
function FirstAudioStream: TAVIAudioStream;
function AddVideoStream(BmpFormat: TBitmapInfoHeader;
FrameRate: Integer;
Codec: Cardinal): Integer;
overload;
function AddVideoStream(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): Integer;
overload;
function AddVideoStream2(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): TAVIVideoStream;
function AddAudioStream(WaveFormat: TWaveFormatEx): Integer;
overload;
function AddAudioStream2(WaveFormat: TWaveFormatEx): TAVIAudioStream;
property Streams: TAviStreamList read FStreams;
end;
function BIHFromBitmap(Bmp: TBitmap;
var BMIH: TBitmapInfoHeader): Boolean;
implementation
function BitmapImageSize(bmp: TBitmap): Cardinal;
var ihs: Cardinal;
begin
GetDIBSizes(bmp.Handle, ihs, Result);
end;
function BIHFromBitmap(Bmp: TBitmap;
var BMIH: TBitmapInfoHeader): Boolean;
var ihs, ims: Cardinal;
bits: Pointer;
begin
GetDIBSizes(Bmp.Handle, ihs, ims);
GetMem(bits, ims);
try
GetDIB(Bmp.Handle, 0, BMIH, bits^);
Result:=true;
finally
FreeMem(bits);
end;
end;
{ TAVIBaseStream }
constructor TAVIBaseStream.Create(AviFile: IAVIFile;
StreamInfo: TAVIStreamInfoW);
begin
if AviFile = nil then
exit;
FAviFile:=AviFile;
FStreamInfo:=StreamInfo;
AviFile.CreateStream(FStream, FStreamInfo);
end;
destructor TAVIBaseStream.Destroy;
begin
FStream:=nil;
inherited;
end;
function TAVIBaseStream.WriteSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
var bt, smp: Integer;
begin
Result:=Succeeded(FStream.Write(Index, 1, lpData, cbSize, Flags, smp, bt));
Inc(FSamples);
end;
function TAVIBaseStream.AddSample(cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
var bt, smp: Integer;
begin
Result:=Succeeded(FStream.Write(FSamples, 1, lpData, cbSize, Flags, smp, bt));
Inc(FSamples);
end;
function TAVIBaseStream.DeleteSamples(Index, Count: Cardinal): Integer;
begin
if Succeeded(FStream.Delete(Index, Count)) then
begin
Result:=Count;
Dec(FSamples, Result);
end
else
Result:=0;
end;
function TAVIBaseStream.ReadSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer): Boolean;
var bt, smp: Integer;
begin
Result:=Succeeded(FStream.Read(Index, 1, lpData, cbSize, bt, smp));
end;
procedure TAVIBaseStream.SetName(Value: string);
begin
FName:=Value;
end;
function TAVIBaseStream.GetStreamType: Cardinal;
begin
Result:=FStreamInfo.fccType;
end;
{ TAVIVideoStream }
constructor TAVIVideoStream.Create(AviFile: IAVIFile;
AFormat: TBitmapInfoHeader;
FrameRate: Integer;
fccHandler: Cardinal);
begin
FAviFile:=AviFile;
FFormat:=AFormat;
FillChar(FStreamInfo, SizeOf(FStreamInfo), 0);
FStreamInfo.fccType:=streamtypeVIDEO;
FStreamInfo.fccHandler:=fccHandler;
FStreamInfo.dwRate:=FrameRate;
if Succeeded(AviFile.CreateStream(FStream, FStreamInfo)) then
FStream.SetFormat(0, @FFormat, SizeOf(FFormat));
end;
destructor TAVIVideoStream.Destroy;
begin
inherited;
end;
function TAVIVideoStream.InsertFrame(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
const flagKeyFrame: array[Boolean] of Integer = (0, AVIIF_KEYFRAME);
begin
if Index = -1 then
Index:=FSamples;
Result:=WriteSample(Index, cbSize, lpData, flagKeyFrame[KeyFrame]);
end;
function TAVIVideoStream.InsertFrame(Index: Integer;
Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
var BmpSize: Cardinal;
begin
Result:=Assigned(Bmp);
if not Result then
exit;
BmpSize:=BitmapImageSize(Bmp);
if Index = -1 then
Index:=FSamples;
Result:=InsertFrame(Index, BmpSize, Bmp.ScanLine[Bmp.Height-1], KeyFrame);
end;
function TAVIVideoStream.AddFrame(Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
begin
Result:=InsertFrame(FSamples, Bmp, KeyFrame);
end;
function TAVIVideoStream.AddFrame(cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
begin
Result:=InsertFrame(FSamples, cbSize, lpData, KeyFrame);
end;
function TAVIVideoStream.DeleteFrames(Index, Count: Cardinal): Integer;
begin
Result:=DeleteSamples(Index, Count);
end;
function TAVIVideoStream.Samples: Cardinal;
begin
Result:=FSamples;
end;
{ TAVIAudioStream }
constructor TAVIAudioStream.Create(AviFile: IAVIFile;
AFormat: TWaveFormatEx);
begin
FAviFile:=AviFile;
FFormat:=AFormat;
end;
destructor TAVIAudioStream.Destroy;
begin
inherited;
end;
{ TAviStreamList }
function TAviStreamList.Add(Stream: TAVIBaseStream): Integer;
begin
inherited Add(Stream);
Result:=Count-1;
end;
function TAviStreamList.Insert(Index: Integer;
Stream: TAVIBaseStream): Integer;
begin
inherited Insert(Index, Stream);
Result:=Index;
end;
function TAviStreamList.Get(Index: Integer): TAVIBaseStream;
begin
Result:=TAVIBaseStream(inherited Get(Index));
end;
procedure TAviStreamList.Put(Index: Integer;
Stream: TAVIBaseStream);
begin
inherited Put(Index, Stream);
end;
procedure TAviStreamList.Notify(Ptr: Pointer;
Action: TListNotification);
begin
if Action = lnDeleted then
TAVIBaseStream(Ptr).Free;
inherited Notify(Ptr, Action);
end;
{ TAviFileHandler }
function TAviFileHandler.AddAudioStream(
WaveFormat: TWaveFormatEx): Integer;
begin
Result:=Streams.Add(TAVIAudioStream.Create(FAviFile, WaveFormat));
end;
function TAviFileHandler.AddAudioStream2(
WaveFormat: TWaveFormatEx): TAVIAudioStream;
begin
Result:=TAVIAudioStream(Streams.Items[AddAudioStream(WaveFormat)]);
end;
function TAviFileHandler.AddVideoStream(BmpFormat: TBitmapInfoHeader;
FrameRate: Integer;
Codec: Cardinal): Integer;
begin
Result:=Streams.Add(TAVIVideoStream.Create(FAviFile, BmpFormat, FrameRate, Codec));
end;
function TAviFileHandler.AddVideoStream(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): Integer;
var BMIH: TBitmapInfoHeader;
begin
if BIHFromBitmap(BmpFormat, BMIH) then
Result:=AddVideoStream(BMIH, FrameRate, Codec)
else
Result:=-1;
end;
function TAviFileHandler.AddVideoStream2(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): TAVIVideoStream;
begin
Result:=TAVIVideoStream(Streams.Items[AddVideoStream(BmpFormat, FrameRate, Codec)]);
end;
constructor TAviFileHandler.Create(FileName: string);
begin
AVIFileInit;
if AVIFileOpen(FAVIFile, PChar(FileName), OF_CREATE or OF_WRITE, nil) <> AVIERR_OK then
raise Exception.CreateFmt('Can''t open file %s for writing', [FileName]);
FStreams:=TAviStreamList.Create;
end;
destructor TAviFileHandler.Destroy;
begin
AVIFileExit;
FreeAndNil(FStreams);
FAVIFile:=nil;
inherited;
end;
function TAviFileHandler.FirstAudioStream: TAVIAudioStream;
var I: Integer;
begin
Result:=nil;
for I:=0 to Streams.Count-1do
if Streams.Items.StreamType = streamtypeAUDIO then
begin
Result:=TAVIAudioStream(Streams.Items);
break;
end;
end;
function TAviFileHandler.FirstVideoStream: TAVIVideoStream;
var I: Integer;
begin
Result:=nil;
for I:=0 to Streams.Count-1do
if Streams.Items.StreamType = streamtypeVIDEO then
begin
Result:=TAVIVideoStream(Streams.Items);
break;
end;
end;
end.
interface
uses Windows, Classes, sysutils, vfw, mmsystem, graphics;
type
TFourCC = packed record
case Integer of
0: (AsCardinal: Cardinal);
1: (AsString: array[0..3] of Char);
end;
TAVIBaseStream = class(TObject)
private
FName: string;
FStream: IAVIStream;
FStreamInfo: TAVIStreamInfoW;
FAviFile: IAVIFile;
protected
FSamples: Cardinal;
public
constructor Create(AviFile: IAVIFile;
StreamInfo: TAVIStreamInfoW);
virtual;
destructor Destroy;
override;
function WriteSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
function AddSample(cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
function ReadSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer): Boolean;
function DeleteSamples(Index, Count: Cardinal): Integer;
procedure SetName(Value: string);
// returns the FOURCC code of the type
function GetStreamType: Cardinal;
property Name: string read FName write SetName;
// streams name ... just to eat more memory
property Stream: IAVIStream read FStream;
// direct acces to the stream object if needed
property StreamType: Cardinal read GetStreamType;
// the streams type (streamtypeVIDEO/AUDIO, ...)
property Samples: Cardinal read FSamples;
// number of samples in the stream
end;
TAVIVideoStream = class(TAVIBaseStream)
private
FFormat: TBitmapInfoHeader;
function Samples: Cardinal;
public
constructor Create(AviFile: IAVIFile;
AFormat: TBitmapInfoHeader;
FrameRate: Integer;
fccHandler: Cardinal);
reintroduce;
destructor Destroy;
override;
function InsertFrame(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
overload;
function InsertFrame(Index: Integer;
Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
overload;
function AddFrame(cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
overload;
function AddFrame(Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
overload;
function DeleteFrames(Index, Count: Cardinal): Integer;
property Frames: Cardinal read Samples;
end;
TAVIAudioStream = class(TAVIBaseStream)
private
FFormat: TWaveFormatEx;
public
constructor Create(AviFile: IAVIFile;
AFormat: TWaveFormatEx);
reintroduce;
destructor Destroy;
override;
end;
TAviStreamList = class(TList)
private
function Get(Index: Integer): TAVIBaseStream;
procedure Put(Index: Integer;
Stream: TAVIBaseStream);
protected
procedure Notify(Ptr: Pointer;
Action: TListNotification);
override;
public
function Insert(Index: Integer;
Stream: TAVIBaseStream): Integer;
function Add(Stream: TAVIBaseStream): Integer;
property Items[Index: Integer]: TAVIBaseStream read Get write Put;
default;
end;
TAviFileHandler = class(TObject)
private
FAviFile: IAVIFile;
FStreams: TAviStreamList;
public
constructor Create(FileName: string);
destructor Destroy;
override;
function FirstVideoStream: TAVIVideoStream;
function FirstAudioStream: TAVIAudioStream;
function AddVideoStream(BmpFormat: TBitmapInfoHeader;
FrameRate: Integer;
Codec: Cardinal): Integer;
overload;
function AddVideoStream(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): Integer;
overload;
function AddVideoStream2(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): TAVIVideoStream;
function AddAudioStream(WaveFormat: TWaveFormatEx): Integer;
overload;
function AddAudioStream2(WaveFormat: TWaveFormatEx): TAVIAudioStream;
property Streams: TAviStreamList read FStreams;
end;
function BIHFromBitmap(Bmp: TBitmap;
var BMIH: TBitmapInfoHeader): Boolean;
implementation
function BitmapImageSize(bmp: TBitmap): Cardinal;
var ihs: Cardinal;
begin
GetDIBSizes(bmp.Handle, ihs, Result);
end;
function BIHFromBitmap(Bmp: TBitmap;
var BMIH: TBitmapInfoHeader): Boolean;
var ihs, ims: Cardinal;
bits: Pointer;
begin
GetDIBSizes(Bmp.Handle, ihs, ims);
GetMem(bits, ims);
try
GetDIB(Bmp.Handle, 0, BMIH, bits^);
Result:=true;
finally
FreeMem(bits);
end;
end;
{ TAVIBaseStream }
constructor TAVIBaseStream.Create(AviFile: IAVIFile;
StreamInfo: TAVIStreamInfoW);
begin
if AviFile = nil then
exit;
FAviFile:=AviFile;
FStreamInfo:=StreamInfo;
AviFile.CreateStream(FStream, FStreamInfo);
end;
destructor TAVIBaseStream.Destroy;
begin
FStream:=nil;
inherited;
end;
function TAVIBaseStream.WriteSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
var bt, smp: Integer;
begin
Result:=Succeeded(FStream.Write(Index, 1, lpData, cbSize, Flags, smp, bt));
Inc(FSamples);
end;
function TAVIBaseStream.AddSample(cbSize: Cardinal;
lpData: Pointer;
Flags: Cardinal): Boolean;
var bt, smp: Integer;
begin
Result:=Succeeded(FStream.Write(FSamples, 1, lpData, cbSize, Flags, smp, bt));
Inc(FSamples);
end;
function TAVIBaseStream.DeleteSamples(Index, Count: Cardinal): Integer;
begin
if Succeeded(FStream.Delete(Index, Count)) then
begin
Result:=Count;
Dec(FSamples, Result);
end
else
Result:=0;
end;
function TAVIBaseStream.ReadSample(Index: Integer;
cbSize: Cardinal;
lpData: Pointer): Boolean;
var bt, smp: Integer;
begin
Result:=Succeeded(FStream.Read(Index, 1, lpData, cbSize, bt, smp));
end;
procedure TAVIBaseStream.SetName(Value: string);
begin
FName:=Value;
end;
function TAVIBaseStream.GetStreamType: Cardinal;
begin
Result:=FStreamInfo.fccType;
end;
{ TAVIVideoStream }
constructor TAVIVideoStream.Create(AviFile: IAVIFile;
AFormat: TBitmapInfoHeader;
FrameRate: Integer;
fccHandler: Cardinal);
begin
FAviFile:=AviFile;
FFormat:=AFormat;
FillChar(FStreamInfo, SizeOf(FStreamInfo), 0);
FStreamInfo.fccType:=streamtypeVIDEO;
FStreamInfo.fccHandler:=fccHandler;
FStreamInfo.dwRate:=FrameRate;
if Succeeded(AviFile.CreateStream(FStream, FStreamInfo)) then
FStream.SetFormat(0, @FFormat, SizeOf(FFormat));
end;
destructor TAVIVideoStream.Destroy;
begin
inherited;
end;
function TAVIVideoStream.InsertFrame(Index: Integer;
cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
const flagKeyFrame: array[Boolean] of Integer = (0, AVIIF_KEYFRAME);
begin
if Index = -1 then
Index:=FSamples;
Result:=WriteSample(Index, cbSize, lpData, flagKeyFrame[KeyFrame]);
end;
function TAVIVideoStream.InsertFrame(Index: Integer;
Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
var BmpSize: Cardinal;
begin
Result:=Assigned(Bmp);
if not Result then
exit;
BmpSize:=BitmapImageSize(Bmp);
if Index = -1 then
Index:=FSamples;
Result:=InsertFrame(Index, BmpSize, Bmp.ScanLine[Bmp.Height-1], KeyFrame);
end;
function TAVIVideoStream.AddFrame(Bmp: TBitmap;
KeyFrame: Boolean): Boolean;
begin
Result:=InsertFrame(FSamples, Bmp, KeyFrame);
end;
function TAVIVideoStream.AddFrame(cbSize: Cardinal;
lpData: Pointer;
KeyFrame: Boolean): Boolean;
begin
Result:=InsertFrame(FSamples, cbSize, lpData, KeyFrame);
end;
function TAVIVideoStream.DeleteFrames(Index, Count: Cardinal): Integer;
begin
Result:=DeleteSamples(Index, Count);
end;
function TAVIVideoStream.Samples: Cardinal;
begin
Result:=FSamples;
end;
{ TAVIAudioStream }
constructor TAVIAudioStream.Create(AviFile: IAVIFile;
AFormat: TWaveFormatEx);
begin
FAviFile:=AviFile;
FFormat:=AFormat;
end;
destructor TAVIAudioStream.Destroy;
begin
inherited;
end;
{ TAviStreamList }
function TAviStreamList.Add(Stream: TAVIBaseStream): Integer;
begin
inherited Add(Stream);
Result:=Count-1;
end;
function TAviStreamList.Insert(Index: Integer;
Stream: TAVIBaseStream): Integer;
begin
inherited Insert(Index, Stream);
Result:=Index;
end;
function TAviStreamList.Get(Index: Integer): TAVIBaseStream;
begin
Result:=TAVIBaseStream(inherited Get(Index));
end;
procedure TAviStreamList.Put(Index: Integer;
Stream: TAVIBaseStream);
begin
inherited Put(Index, Stream);
end;
procedure TAviStreamList.Notify(Ptr: Pointer;
Action: TListNotification);
begin
if Action = lnDeleted then
TAVIBaseStream(Ptr).Free;
inherited Notify(Ptr, Action);
end;
{ TAviFileHandler }
function TAviFileHandler.AddAudioStream(
WaveFormat: TWaveFormatEx): Integer;
begin
Result:=Streams.Add(TAVIAudioStream.Create(FAviFile, WaveFormat));
end;
function TAviFileHandler.AddAudioStream2(
WaveFormat: TWaveFormatEx): TAVIAudioStream;
begin
Result:=TAVIAudioStream(Streams.Items[AddAudioStream(WaveFormat)]);
end;
function TAviFileHandler.AddVideoStream(BmpFormat: TBitmapInfoHeader;
FrameRate: Integer;
Codec: Cardinal): Integer;
begin
Result:=Streams.Add(TAVIVideoStream.Create(FAviFile, BmpFormat, FrameRate, Codec));
end;
function TAviFileHandler.AddVideoStream(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): Integer;
var BMIH: TBitmapInfoHeader;
begin
if BIHFromBitmap(BmpFormat, BMIH) then
Result:=AddVideoStream(BMIH, FrameRate, Codec)
else
Result:=-1;
end;
function TAviFileHandler.AddVideoStream2(BmpFormat: TBitmap;
FrameRate: Integer;
Codec: Cardinal): TAVIVideoStream;
begin
Result:=TAVIVideoStream(Streams.Items[AddVideoStream(BmpFormat, FrameRate, Codec)]);
end;
constructor TAviFileHandler.Create(FileName: string);
begin
AVIFileInit;
if AVIFileOpen(FAVIFile, PChar(FileName), OF_CREATE or OF_WRITE, nil) <> AVIERR_OK then
raise Exception.CreateFmt('Can''t open file %s for writing', [FileName]);
FStreams:=TAviStreamList.Create;
end;
destructor TAviFileHandler.Destroy;
begin
AVIFileExit;
FreeAndNil(FStreams);
FAVIFile:=nil;
inherited;
end;
function TAviFileHandler.FirstAudioStream: TAVIAudioStream;
var I: Integer;
begin
Result:=nil;
for I:=0 to Streams.Count-1do
if Streams.Items.StreamType = streamtypeAUDIO then
begin
Result:=TAVIAudioStream(Streams.Items);
break;
end;
end;
function TAviFileHandler.FirstVideoStream: TAVIVideoStream;
var I: Integer;
begin
Result:=nil;
for I:=0 to Streams.Count-1do
if Streams.Items.StreamType = streamtypeVIDEO then
begin
Result:=TAVIVideoStream(Streams.Items);
break;
end;
end;
end.
3
3cs
Unregistered / Unconfirmed
GUEST, unregistred user!
好几天没光顾了，原来有人回答了，谢谢了，看看再说！
Z
zhuoyuesky
Unregistered / Unconfirmed
GUEST, unregistred user!
学习
W
wujer
Unregistered / Unconfirmed
GUEST, unregistred user!
我来了！
3
3cs
Unregistered / Unconfirmed
GUEST, unregistred user!
问题还是没解决，兄弟帮帮忙吧！
3
3cs
Unregistered / Unconfirmed
GUEST, unregistred user!
如有提供代码者，不方便的话请发到我的邮箱：lujinhu@163.net,以500分加500MEONY答谢！
B
barton
Unregistered / Unconfirmed
GUEST, unregistred user!
jingtao:用流播放DivX有什么讲究吗？说说。我可以另开贴给你高分。
3
3cs
Unregistered / Unconfirmed
GUEST, unregistred user!
接受答案了.