Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

Bitmaps to AVI [D7, WinXP]


Ozone ©   (2004-10-21 14:19:00) 

Много химичил с sabj'ем, но все-равно получается с БОЛЬШИМ косяком. Решил написать сюда, может кто поможет советом.

(использовал как образец исходники TAviWriter).

Сама процедура записи в (VideoStream: IAVIStream)

var
  pFile          : IAVIFile;
  StreamInfo     : TAVIStreamInfo;
  pStream        : IAVIStream;
  BitmapInfo     : PBITMAPINFOHEADER;
  BitmapInfoSize : DWORD;
  BitmapSize     : DWORD;
  BitmapBits     : pointer;
  Bitmap         : TBitmap;
  AVIERR         : integer;
  i              : integer;
{/*----------------------------------------------------*/}
if (AVIFileOpen(pFile, pChar('~temp.avi'), OF_CREATE OR OF_WRITE , nil)<> AVIERR_OK) then
       raise Exception.Create('Failed to create AVI video work file');

    Bitmap        := TBitmap.create;
    Bitmap.Height := FWidth;
    Bitmap.Width  := FHeight;

    try
      FillChar(StreamInfo, sizeof(StreamInfo), 0);

      StreamInfo.dwRate := FRate;
      StreamInfo.dwScale := FScale;
      StreamInfo.fccType := streamtypeVIDEO;
      StreamInfo.fccHandler := 0;
      StreamInfo.dwFlags := 0;
      StreamInfo.dwSuggestedBufferSize := 0;
      StreamInfo.rcFrame.Left := 0;
      // ширина Bitmap из Images (см. ниже)
      StreamInfo.rcFrame.Right := FWidth;
      StreamInfo.rcFrame.Top := 0;
      // высота Bitmap из Images (см. ниже)  
      StreamInfo.rcFrame.Bottom := FHeight;

      if (AVIFileCreateStream(pFile, pStream, StreamInfo) <> AVIERR_OK) then
          raise Exception.Create('Failed to create AVI video stream');

      try
         // Images - динамич массив Bitmap'ов
         for i:=0 to High(Images) do begin
           try
              Bitmap.Canvas.StretchDraw(Rect(0,0,FWidth,FHeight),Images[i]);

              InternalGetDIBSizes(Bitmap.Handle, BitmapInfoSize, BitmapSize, 0);

              if (BitmapInfoSize = 0) then
                 raise Exception.Create('Failed to retrieve bitmap info');

              GetMem(BitmapInfo, BitmapInfoSize);
              GetMem(BitmapBits, BitmapSize);

              InternalGetDIB(Bitmap.Handle, 0, BitmapInfo^, BitmapBits^, 0);

              if i = 0 then
                if (AVIStreamSetFormat(pStream, 0, BitmapInfo, BitmapInfoSize) <> AVIERR_OK) then
                   raise Exception.Create('Failed to set AVI stream format');

              AVIERR := AVIStreamWrite(pStream, i, 1, BitmapBits, BitmapSize, AVIIF_KEYFRAME, nil, nil);
              if AVIERR <> AVIERR_OK then
                raise Exception.Create('Failed to add frame to AVI. Err='+ inttohex(AVIERR,8));
           finally
             if (BitmapInfo <> nil) then FreeMem(BitmapInfo);
             if (BitmapBits <> nil) then FreeMem(BitmapBits);
           end;
         end;

         if CreateEditableStream(VideoStream,pStream) <> AVIERR_OK then
            raise Exception.Create('Could not create Video Stream');
      finally
        pStream := nil;
      end;
    finally
      BitMap.Free;
    end;


Ну и потом собственно в AVI:


var
  Streams    : APAVISTREAM;
  plpOptions : APAVICompressOptions;
  AVIERR     : integer;
  nStream    : integer;
begin
    nStream := 1;
    Streams[0] := VideoStream;
    plpOptions[0] := nil;

    try
      AVIERR := AVISaveA(PChar(FileName),
                            nil,
                            nil,
                            nStream,
                            Streams,
                            plpOptions);
      if AVIERR <> AVIERR_OK then
           raise Exception.Create('Unable to write output file');
    finally
      if assigned(VideoStream) then
        VideoStream := nil;
    end;

    DeleteFile('~temp.avi');


где InternalGetDIBSizes, InternalGetDIB, InitializeBitmapInfoHeader (Graphics.pas) тоже переделаны (код приведу ниже).

Дык вот, проблема в том, что загоняю файл вида http://www.test-mbit.narod.ru/old.JPG, а получаю http://www.test-mbit.narod.ru/new.JPG.Вы можете сказать что я указываю при "вшивании" не те размеры. Нет, это не так (проверено debugger'ом). Если бы даже это было так - там же стоит StretchDraw!!!
Вобщем незнаю куды копать. Поможите.

Ozone   (2004-10-22 02:01:00) [1]

Pavia   (21.10.04 17:33) [3]

Ёб... тв... мат... Спасибо!!! Вот дурак! Неделю голову ломал!

Pavia   (2004-10-21 17:33:00) [2]

Bitmap        := TBitmap.create;
   Bitmap.Height := FWidth;
   Bitmap.Width  := FHeight;

???

Ozone   (2004-10-21 15:58:00) [3]

ЗЫ: размеры у выходного AVI рамерам перевернутого Bitmap'a, который вставляли...

Ozone   (2004-10-21 14:22:00) [4]

Вот обещанные процедуры:


procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader;
 PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
 DIB  : TDIBSection;
 Bytes  : Integer;
 function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
 begin
   Dec(Alignment);
   Result := ((Bits * BitsPerPixel) + Alignment) and not Alignment;
   Result := Result SHL 3;
 end;
begin
 DIB.dsbmih.biSize := 0;
 Bytes := GetObject(Bitmap, SizeOf(DIB), @DIB);
 if (Bytes = 0) then
   raise Exception.Create('Invalid bitmap');
//    Error(sInvalidBitmap);

 if (Bytes >= (sizeof(DIB.dsbm) + sizeof(DIB.dsbmih))) and
   (DIB.dsbmih.biSize >= sizeof(DIB.dsbmih)) then
   Info := DIB.dsbmih
 else
 begin
   FillChar(Info, sizeof(Info), 0);
   with Info, DIB.dsbm do
   begin
     biSize := SizeOf(Info);
     biWidth := bmWidth;
     biHeight := bmHeight;
   end;
 end;
 case PixelFormat of
   pf1bit: Info.biBitCount := 1;
   pf4bit: Info.biBitCount := 4;
   pf8bit: Info.biBitCount := 8;
   pf24bit: Info.biBitCount := 24;
 else
//    Error(sInvalidPixelFormat);
   raise Exception.Create('Invalid pixel foramt');
   // Info.biBitCount := DIB.dsbm.bmBitsPixel * DIB.dsbm.bmPlanes;
 end;
 Info.biPlanes := 1;
 Info.biCompression := BI_RGB; // Always return data in RGB format
 Info.biSizeImage := AlignBit(Info.biWidth, Info.biBitCount, 32) * Cardinal(abs(Info.biHeight));
end;

function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
 var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean;
// From graphics.pas, "optimized" for our use
var
 OldPal : HPALETTE;
 DC  : HDC;
begin
 InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);
 OldPal := 0;
 DC := CreateCompatibleDC(0);
 try
   if (Palette <> 0) then
   begin
     OldPal := SelectPalette(DC, Palette, False);
     RealizePalette(DC);
   end;
   Result := (GetDIBits(DC, Bitmap, 0, abs(TBitmapInfoHeader(BitmapInfo).biHeight),
     @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0);
 finally
   if (OldPal <> 0) then
     SelectPalette(DC, OldPal, False);
   DeleteDC(DC);
 end;
end;

procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer;
 var ImageSize: longInt; PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
 Info  : TBitmapInfoHeader;
begin
 InitializeBitmapInfoHeader(Bitmap, Info, PixelFormat);
 // Check for palette device format
 if (Info.biBitCount > 8) then
 begin
   // Header but no palette
   InfoHeaderSize := SizeOf(TBitmapInfoHeader);
   if ((Info.biCompression and BI_BITFIELDS) <> 0) then
     Inc(InfoHeaderSize, 12);
 end else
   // Header and palette
   InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl Info.biBitCount);
 ImageSize := Info.biSizeImage;
end;


Писал разработчикам, сказали что не имеют понятия почему получается такой баг.

Наверх

Титульная страница Поиск, карта сайта Написать письмо