Solved

Creating a compressed avi block from bitmaps

Posted on 2002-05-23
19
2,829 Views
Last Modified: 2008-10-13
I need to create a compressed avi block from some bitmaps
not to a file but to some memory block which I will send over internet later on
I also need a way to play that block on the other side
it has to be compressed with any available codec installed on the system OR some direct interface to a known encoder
can be made using vfw or DirectShow or any other method
but it has to be fast :)

ofcourse I need full delphi source and absolutely no ActiveX controls

I can spare more points if needed
0
Comment
Question by:Lee_Nover
  • 8
  • 5
  • 3
  • +2
19 Comments
 
LVL 1

Expert Comment

by:mgazza
ID: 7030365
iv made a program that lets you view an avi from a list of bmp's but i too would like to know haow to make avi's
0
 
LVL 9

Expert Comment

by:ginsonic
ID: 7031269
I have a sample how to create an avi file from couple bitmaps and how to send an image over net . Don't have idea about video streaming .
0
 
LVL 9

Expert Comment

by:ginsonic
ID: 7031271
Maybe interesting an audio streamer . With couple modification can play avi files .
0
 
LVL 12

Author Comment

by:Lee_Nover
ID: 7031300
:)
I have lots of samples on making an avi FILE with vfw
I also have the Audio streaming part using ACMCompos 1.4 and Indy UDP with my DynamicBuffer™ :)
all I need to do now is to make a compressed avi block from a few frames
and then play it back on the other side
I'm going over vp32 ( www.on2.com ) Open source codec, but they have really weird licensing
0
 
LVL 1

Expert Comment

by:mgazza
ID: 7031591
so how do you make an avi give me the sorce code plz i will be very greatful
0
 
LVL 12

Author Comment

by:Lee_Nover
ID: 7032167
well the easyest way is to use the free TAviWriter component :)
www.torry.net/video.htm
0
 
LVL 2

Expert Comment

by:freshman3k
ID: 7033864
Hello!

Why not take all the bitmaps together and compress(via winzip like compression algorithm) them  as one stream and then send it, and then the other side will recieve,decompress and display it?

If you like the idea, I can tell you step by step how to do it! :-)

0
 
LVL 2

Expert Comment

by:freshman3k
ID: 7033867
And I frogot to add that everything will be done in memory!
0
 
LVL 1

Expert Comment

by:mgazza
ID: 7034222
i can help you with the preveiw of the avi and i have updated the Taviwriter just email me rcmgazza2@hotmail.com i have also made another componant that alows you to save and load the lastpos of the form!!!
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 12

Author Comment

by:Lee_Nover
ID: 7034357
hum
now I have every frame as a jpeg in a buffer
that's way better than lots of bitmaps in one zip in memory
and I do know how to zip that :)

but that's still too BIG, like having an avi with all the frames as keyframes
the main point is that the frames are just the difference between two next frames which greatly reduces memory

I've found VCM and I will start making component wrappers for it
any help is still appreciated
0
 
LVL 1

Expert Comment

by:mgazza
ID: 7034486
so u want some thing like this!
bitmap..avi..compress..send..uncompress..avi
0
 
LVL 12

Author Comment

by:Lee_Nover
ID: 7034611
kinda yeah, all has to be done in memory
I already have a buffer that stores raw data whatever it is ...
so with VCM I'll simly compress the frames and store those in the buffer
I won't need any avi stuff :)
same will be for the clientside player
it has a buffer and retrieves the buffer blocks periodically
so when retrieving the block I'll uncompress the frame
sound simple and I hope it will be simple :)
I'll start on the VCM components on monday
help is still aprreciated
maybe something else that works like that ?
or a ready implementation of the VCM
oh .. by VCM I mean Video Compression Manager :) (like ACM)
0
 
LVL 1

Expert Comment

by:mgazza
ID: 7034630
what if you did this
open each bmp on a text file seperate each bmp with something and compress the textfile!! eg..
//sender
for i:=0 to filelistbox1.items.count-1 do
begin
memo1.lines.loadfromfile(filelistbox1.strings[i]);
memo2.lines.add('[nextbmp]');//the seporator;
memo2.lines.add(memo1.lines.text);
memo1.lines.clear;
end;
//compress
(eg. compess_as 'bmpsinfo.zip')
//turn text into list of bms using taviwriter;

for i:=0 to memo1.lines.count-1 do
begin
if memo1.lines.strings[i]<>'[nextbmp]'then
begin
bmplist.add(memo1.lines.[i])
end;

end;

0
 
LVL 12

Author Comment

by:Lee_Nover
ID: 7034640
?
that would help me with what ?
and I don't have those bitmaps on disk
I 'grab' them from a video stream
it's for "broadcasting" a video stream from a webcam
I use my own protocol for lots of reasons
and the frames grabbed are used for calculating the movement percentage
and for streaming :)

the point in video compression is that the next frame (if not a keyframe) is only a difference between the last frame and the current one
if there is no moving in the scene then the next frame will be almost 0 byte size because there's no change !
I was thinking about creating my own xor algorithm but there's really no need
VCM :)
0
 
LVL 12

Author Comment

by:Lee_Nover
ID: 7044531
ok I've done a class that uses VCM
it's working quite well, some codecs are problematic but that's codec specific problems and will solve those later on

here's the code for the whole VideoCoDec class and it's usage



-------------------------------------------------------

{

    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, vfw;


const
  VFW_EXT_RESULT = 1;

resourcestring
  sErrorICGetInfo = 'Unable to retrieve video compressor information';
  sErrorICCompressBegin = 'Cannot start video compression'#13#10'Error code: %d';
  sErrorICCompressBeginBF = '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;
    FMaxFrameSize: Cardinal;
    FMaxPackedSize: Cardinal;
    FSlopSpace: Cardinal;

    FCodecName: string;
    FCodecDescription: string;

    pConfigData: Pointer;
    cbConfigData: Cardinal;
    function InternalInit(const HasComp: Boolean = false): Boolean;
    procedure SetCompVars(CompVars: TCompVars);
    procedure ClearCompVars(var CompVars: TCompVars);
    procedure CloseDecompressor;
    procedure CloseCompressor;
    procedure CloseDrivers;
    procedure StartCompressor;
    procedure StartDecompressor;

  public
    constructor Create;
    destructor Destroy; override;

    function Init(CompVars: TCompVars): Boolean; overload;
    function Init(InputFormat, OutputFormat: TBitmapInfo;
      const Quality, KeyRate: Integer): Boolean; overload;

    procedure Start;
    procedure Finish;
    function ChooseCodec: Boolean;
    procedure ConfigureCompressor;

    procedure SetDataRate(const lDataRate, lUsPerFrame, lFrameCount: Integer);
    procedure SetQuality(const Value: Integer);
    function GetQuality: 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 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 CodecName: string read FCodecName;
    property CodecDescription: string read FCodecDescription;
  end;


function CheckTrueFalse(const Condition: Boolean; const ifTrue, ifFalse: Integer): Integer;overload;
function CheckTrueFalse(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;


implementation


function CheckTrueFalse(const Condition: Boolean; const ifTrue, ifFalse: Integer): Integer;overload;
begin
     if Condition then
        Result:=ifTrue
     else
        Result:=ifFalse;
end;

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



{ 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;
     pConfigData:=nil;
     cbConfigData:=0;
end;

destructor TVideoCoDec.Destroy;
begin
     ReallocMem(FPrevBuffer, 0);
     ReallocMem(FBuffCompOut, 0);
     ReallocMem(FBuffDeCompOut, 0);
     ReallocMem(pConfigData, 0);
     // these could be freed by ICCompressFree
     // but I don't know what that function REALLY does !
     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;
    res: Cardinal;
    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);
     res:=ICGetInfo(cv.hic, @info, SizeOf(info));
     Result:=res <> 0;
     if not Result then
     begin
//       SetLastError();
       exit;
     end;

     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't do 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't done, 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;

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 we don'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;

     ICSendMessage(cv.hic, ICM_COMPRESS_FRAMES_INFO, WPARAM(@icf), SizeOf(TICCOMPRESSFRAMES));
end;

procedure TVideoCoDec.Start;
begin
     StartCompressor;
     StartDecompressor;
end;

procedure TVideoCoDec.StartCompressor;
var res: LRESULT;
begin
     FFrameNum:=0;
     FCompressorStarted:=false;

     // Start compression process
     res:=ICCompressBegin(cv.hic, @(cv.lpbiIn^.bmiHeader), @(cv.lpbiOut^.bmiHeader));
     if res <> ICERR_OK then exit;

     // Start decompression process if necessary
     if Assigned(FPrevBuffer) then
     begin
       res:=ICDecompressBegin(cv.hic, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader));
       if res <> ICERR_OK then
       begin
         ICCompressEnd(cv.hic);
         exit;
       end;
     end;

     FCompressorStarted:=true;
end;

procedure TVideoCoDec.StartDecompressor;
var res: LRESULT;
begin
     // Start decompression process
     res:=ICDecompressBegin(hICDec, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader));
     FDecompressorStarted:=res = ICERR_OK;
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
        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;
   res: 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 the docs (see below)
     lKeyRateCounterSave:=FKeyRateCounter;

     // Figure out if we should force a keyframe.  If we don'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 (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;

     // 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, but do 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.  Docs 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;

     res:=ICCompress(
       cv.hic, dwFlagsIn, @(cv.lpbiOut^.bmiHeader), FBuffCompOut,
       @(cv.lpbiIn^.bmiHeader), ImageData, @dwChunkId, @dwFlags, FFrameNum,
       CheckTrueFalse(FFrameNum > 0, lAllowableFrameSize, $0FFFFFF), cv.lQ,
       CheckTrueFalse(HasFlag(dwFlagsIn, ICCOMPRESS_KEYFRAME), nil, @(cv.lpbiIn^.bmiHeader)),
       CheckTrueFalse(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 (res = ICERR_OK) and Assigned(FPrevBuffer) and
        ((cv.lKey = 0) or (FKeyRateCounter > 1)) then
          res:=ICDecompress(cv.hic,
            CheckTrueFalse(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');
     }

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

     Result:=FBuffCompOut;
end;

function TVideoCoDec.UnpackFrame(ImageData: Pointer; KeyFrame: Boolean;
  var Size: Cardinal): Pointer;
var res: Integer;
begin
     Size:=cv.lpbiIn^.bmiHeader.biSizeImage;
     ReallocMem(FBuffDecompOut, Size);
     res:=ICDecompress(hICDec,
       CheckTrueFalse(KeyFrame, 0, ICDECOMPRESS_NOTKEYFRAME),
       @(cv.lpbiOut^.bmiHeader), ImageData, @(cv.lpbiIn^.bmiHeader), FBuffDecompOut);


     Result:=nil;
     if (res <> 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;

end.




---------------------------------------------------------





unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtDlgs, StdCtrls, ExtCtrls, vfw, VideoCoDec;

type
  PFrameData = ^TFrameData;
  TFrameData = packed record
    Size: Cardinal;
    KeyFrame: Boolean;
    Data: Pointer;
  end;

  TForm1 = class(TForm)
    btnAdd: TButton;
    imgDisplay: TImage;
    lbPics: TListBox;
    btnDel: TButton;
    btnPrev: TButton;
    btnNext: TButton;
    OpenPicD: TOpenPictureDialog;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btnAddClick(Sender: TObject);
    procedure btnDelClick(Sender: TObject);
    procedure btnPrevClick(Sender: TObject);
    procedure btnNextClick(Sender: TObject);
    procedure lbPicsClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
    vsc: TVideoCoDec;
    lastBmp: TBitmap;
    Initialized: Boolean;

    procedure Init(hBmp: HBITMAP);
    procedure AddBitmap(bmp: TBitmap; Name: string);
  public
    { Public declarations }
    procedure UnpackImage;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}


procedure TForm1.FormCreate(Sender: TObject);
begin
     vsc:=TVideoCoDec.Create;
     lastBmp:=TBitmap.Create;
     DoubleBuffered:=true;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var I: Integer;
    p: PFrameData;
begin
     vsc.Finish;
     FreeAndNil(vsc);
     FreeAndNil(lastBmp);

     for I:=0 to lbPics.Count-1 do
     begin
       p:=PFrameData(lbPics.Items.Objects[I]);
       FreeMem(p^.Data, p^.Size);
       Dispose(p);
     end;
end;

procedure TForm1.Init(hBmp: HBITMAP);
var fccHandler: TFourCC;
    DIB: TDibSection;
    bmiIn: TbitmapInfo;
    bmiOut: TBitmapInfo;
begin
     fccHandler.AsString:='VP31';

     GetObject(hBmp, SizeOf(DIB), @DIB);
     FillChar(bmiIn, SizeOf(TBitmapInfo), 0);
     FillChar(bmiOut, SizeOf(TBitmapInfo), 0);

     bmiIn.bmiHeader:=DIB.dsBmih;
     bmiOut.bmiHeader:=DIB.dsBmih;
     bmiOut.bmiHeader.biCompression:=fccHandler.AsCardinal;

     Initialized:=vsc.Init(bmiIn, bmiOut, 50 * 100, 10);
     if not Initialized then exit;
     vsc.SetDataRate(30, 100 * 1000, 1);
     vsc.Start;
     Initialized:=true;
end;

procedure TForm1.UnpackImage;
var lpFrame: PFrameData;
    lpNF: Pointer;
    lpSize: Cardinal;
    bmi: TBitmapInfo;
    bmih: TBitmapInfoHeader;
    usage: Integer;
    PaintMode: Integer;
begin
     if lbPics.ItemIndex < 0 then exit;
     lpFrame:=PFrameData(lbPics.Items.Objects[lbPics.ItemIndex]);
     lpNF:=vsc.UnpackFrame(lpFrame^.Data, lpFrame^.KeyFrame, lpSize);
     if lpSize = 0 then
     begin
       Caption:='eeek .. error !';
       exit;
     end
     else
       Caption:='decompressed frame ' + IntToStr(lpFrame^.Size);

     bmi:=vsc.biInput;
     bmih:=bmi.bmiHeader;
     usage:=CheckTrueFalse(bmih.biClrUsed = 0, DIB_RGB_COLORS, DIB_PAL_COLORS);
     PaintMode:=CheckTrueFalse(lpFrame^.KeyFrame, SRCCOPY, MERGECOPY);

     with imgDisplay.Picture.Bitmap do
     try
        Width:=bmih.biWidth;
        Height:=bmih.biHeight;
        if StretchDIBits(Canvas.Handle, 0, 0, bmih.biWidth, bmih.biHeight,
          0, 0, bmih.biWidth, bmih.biHeight, lpNF, bmi, usage, PaintMode) = 0 then
            Caption:='bummer';
     finally
        imgDisplay.Repaint;
     end;
end;

procedure TForm1.AddBitmap(bmp: TBitmap; Name: string);
var newFrame: Pointer;
    lpFrame: PFrameData;
begin
     New(lpFrame);
     newFrame:=vsc.PackFrame(bmp.ScanLine[bmp.Height-1], lpFrame^.KeyFrame, lpFrame^.Size);
     if lpFrame^.Size = 0 then
     begin
       Dispose(lpFrame);
       Caption:='eeek napaka pr dodajanju bitmapa';
       exit;
     end;
     GetMem(lpFrame^.Data, lpFrame^.Size);
     CopyMemory(lpFrame^.Data, newFrame, lpFrame^.Size);
     lbPics.AddItem(Format('%s', [Name]), TObject(lpFrame));
end;

procedure TForm1.btnAddClick(Sender: TObject);
var I: Integer;
begin
     if not OpenPicD.Execute then exit;
     TStringList(OpenPicD.Files).Sort;
     for I:=0 to OpenPicD.Files.Count-1 do
     begin
       lastBmp.LoadFromFile(OpenPicD.Files[I]);
//     MakeCompatibleBitmap(lastBmp);
       if not Initialized then
          Init(lastBmp.Handle);
         
       AddBitmap(lastBmp, ExtractFileName(OpenPicD.Files[I]));
     end;
end;

procedure TForm1.btnDelClick(Sender: TObject);
var p: PFrameData;
begin
     if lbPics.ItemIndex < 0 then exit;
     p:=PFrameData(lbPics.Items.Objects[lbPics.ItemIndex]);
     FreeMem(p^.Data, p^.Size);
     Dispose(p);
     lbPics.Items.Delete(lbPics.ItemIndex);
end;

procedure TForm1.btnPrevClick(Sender: TObject);
begin
     if lbPics.Count < 0 then exit;
     if lbPics.ItemIndex = 0 then
        lbPics.ItemIndex:=lbPics.Count-1
     else
        lbPics.ItemIndex:=lbPics.ItemIndex-1;

     UnpackImage;
end;

procedure TForm1.btnNextClick(Sender: TObject);
begin
     if lbPics.Count < 0 then exit;
     if lbPics.ItemIndex = lbPics.Count-1 then
        lbPics.ItemIndex:=0
     else
        lbPics.ItemIndex:=lbPics.ItemIndex+1;
       
     UnpackImage;
end;

procedure TForm1.lbPicsClick(Sender: TObject);
begin
     UnpackImage;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
     vsc.ConfigureCompressor;
end;

end.



------------------------------------------------------


for the latest source try this link :
http://lee.nover.has.his.evilside.org/isapi/pas2html.dll/pas2html?File=/delphi/Projects/VCMTest


hope this helps someone
now I need to find a way how to close this topic since noone even got close to what I wanted to do
0
 
LVL 12

Author Comment

by:Lee_Nover
ID: 7044950
moderators: please close this topic as PAQ
0
 
LVL 9

Expert Comment

by:ginsonic
ID: 7045124
Go to Community Support and put a question with 0 points .
Name it 'Please delete ...' and get there the link to this question . That's all.

Regards,
Nick

P.S. Have you thinking to my proposal ? About dll and handler sample .
0
 
LVL 12

Author Comment

by:Lee_Nover
ID: 7045446
tnx
I think it might be very usefull and could close it as PAQ

about that dll stuff ...
yep, I'll write a lil sample app :)
0
 
LVL 1

Accepted Solution

by:
Computer101 earned 0 total points
ID: 7045598
Points refunded and question PAQ'ed.

Computer101
E-E Moderator
0

Featured Post

What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

Join & Write a Comment

Objective: - This article will help user in how to convert their numeric value become words. How to use 1. You can copy this code in your Unit as function 2. than you can perform your function by type this code The Code   (CODE) The Im…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
In this tutorial you'll learn about bandwidth monitoring with flows and packet sniffing with our network monitoring solution PRTG Network Monitor (https://www.paessler.com/prtg). If you're interested in additional methods for monitoring bandwidt…
This video explains how to create simple products associated to Magento configurable product and offers fast way of their generation with Store Manager for Magento tool.

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

14 Experts available now in Live!

Get 1:1 Help Now