[Delphi] IBasicVideo.GetCurrentImage - do TBitmap

0

W jaki sposób mogę sprowadzić do TBitmap zrzut wykonany procedurą GetCurrentImage w IBasicVideo?

0

Pomoże ktooooooś??

0
 ErrCode := dsBasicVideo.GetCurrentImage(@PLen,nil);
If ErrCode = S_OK then
Begin
GetMem(P,PLen);
If dsBasicVideo.GetCurrentImage(@PLen,@P) = S_OK then
Begin
S := NextBitmap;
AssignFile(F,S);
Rewrite(F,1);
BlockWrite(F,Pointer(P)^,PLen);
CloseFile(F);
End;
FreeMem(P,PLen);
End
Else ShowMessage('Fail: '+IntToHex(ErrCode,Cool);

Więcej informacji znajdziesz tu:
http://www.progdigy.com/modules.php?name=Forums&file=viewforum&f=1

0

Już ponad miesiąc usiłuję to zrobić.....i nic..... no nie wiem....szukałem na google ale niewiele tam znalazłem..... na progdigy.com był przykład z GetCurrentImage - ale nie działa, nie tworzy zrzutu.....

0

Oj słabo szukałeś.
Mi to zajęło 2 godzinki i zrzucanie ramek działa.

Po pierwsze :
http://msdn2.microsoft.com/en-us/library/ms784615.aspx

This method fails if the renderer is using DirectDraw acceleration. Unfortunately, this depends on the end-user's hardware configuration, so in practice this method is not reliable.

Czyli nie zadziała przy akceleracji DirectDraw - użyj renderera VMR (ja użyłem programu VMRPlayWin z katalogu demo w DSPACK)

Po drugie elegancki kod zapodał Marcel Majoor na forum, które Ci wskazałem:
http://www.progdigy.com/modules.php?name=Forums&file=viewtopic&t=3154

Jest tam dodatkowo obsługa VMR7 i VMR9

Można również dodać filtr FSampleGrabber, który wykona odpowiednią robotę - http://www.progdigy.com/modules.php?name=Forums&file=viewtopic&t=690


No, a tu obiecany kod - dodaj przycisk Button1 - "Grab" do aplikacji VMRPlayWin i testuj do bólu :)


function GetDibHeaderSize(Dib: PBitmapInfo): Integer;
begin
  // Defaults for colors used, so get the color table count from
  // the number of bits per pixel
  if (Dib.bmiHeader.biClrUsed = 0) then
  begin
    case Dib.bmiHeader.biBitCount of
      1: Dib.bmiHeader.biClrUsed := 2;
      2: Dib.bmiHeader.biClrUsed := 4;
      3: Dib.bmiHeader.biClrUsed := 8;
      4: Dib.bmiHeader.biClrUsed := 16;
      5: Dib.bmiHeader.biClrUsed := 32;
      6: Dib.bmiHeader.biClrUsed := 64;
      7: Dib.bmiHeader.biClrUsed := 128;
      8: Dib.bmiHeader.biClrUsed := 256;
    end;
  end;
  Result := Dib.bmiHeader.biSize + (Dib.bmiHeader.biClrUsed * 4);
  if ((Dib.bmiHeader.biCompression = BI_BITFIELDS) and (Dib.bmiHeader.biSize = SizeOf(TBitmapInfoHeader))) then
    Result := Result + 12;
end;


function AlignScan(Width: Dword; Depth: Dword): Dword;
begin
  Result := (((Width * Depth) + $1F) and $FFFFFFE0) div 8;
end;



function GetDibDataSize(Dib: PBitmapInfo): Integer;
begin
  case Dib.bmiHeader.biCompression of
    BI_RGB, BI_BITFIELDS:
      begin
        Result := Integer(AlignScan(Dword(Dib.bmiHeader.biWidth), Dword(Dib.bmiHeader.biBitCount))) * Abs(Dib.bmiHeader.biHeight);
        Dib.bmiHeader.biSizeImage := Result;
      end;
    else Result := Dib.bmiHeader.biSizeImage;
  end;
end;


function PackedDibToDibSection(Dib: PBitmapInfo): HBITMAP;
var
  BmHead   : TBitmapInfoHeader;
  HeadSize : Integer;
  DataSize : Integer;
  DataBits : Pointer;
begin
  CopyMemory(@BmHead, Dib, SizeOf(Bmhead));
  // Get header and data size
  HeadSize := GetDibHeaderSize(@BmHead);
  DataSize := GetDibDataSize(@BmHead);
  // Create DibSection based on header
  Result := CreateDibSection(0, Dib^, DIB_RGB_COLORS, DataBits, 0, 0);
  // Copy bitmap to it
  if Result <> 0 then
    CopyMemory(DataBits, Pointer(@PByteArray(Dib)^[HeadSize]), DataSize);
end;


procedure TFormPlayWin.Button1Click(Sender: TObject);
var
dsBasicVideo: IBasicVideo;
dsMediaControl: IMediaControl;
ErrCode : HResult;
Local       : PBitmapInfo;
ASize  : Integer;
ABitmap : HBITMAP;
Bitmap  : Graphics.TBitmap;
pfs: TFilterState;

begin
//pobieram interfejs do dsBasicVideo
(FilterGraph as IGraphBuilder).QueryInterface(IID_IBasicVideo,dsBasicVideo);
if not assigned(dsBasicVideo) then
begin
ShowMessage('Interface dsBasicVideo error !!!');
exit;
end;

//dajemy graph w stan pauzy
ErrCode := FilterGraph.QueryInterface(IID_IMediaControl,dsMediaControl);
if assigned(dsMediaControl) then
begin
dsMediaControl.Pause;
dsMediaControl.GetState(1,pfs);//State_Paused
end;

//gdy podamy nil dostaniemy rozmiar
ASize := 0;
Local := nil;
ErrCode := dsBasicVideo.GetCurrentImage(ASize, Local^);


//mamy rozmiar i co za tym idzie obrazek
If ErrCode = S_OK then
Begin
  try
    GetMem(Local, ASize);
    If dsBasicVideo.GetCurrentImage(ASize, Local^) = S_OK then
    ABitmap := PackedDibToDibSection(Local);
    Bitmap := Graphics.TBitmap.Create;
    Bitmap.Handle := ABitmap;
    Bitmap.SaveToFile('c:\image_0001.bmp');
  finally
    FreeMem(Local);
    Bitmap.Free;
  end;
End
Else ShowMessage('Fail: '+IntToHex(ErrCode,8));

//startujemy dalej film
if assigned(dsMediaControl) then DsMediaControl.Run;
end;

Kod nie jest oczywiście optymalny - po 2 godzinach nie mam już czasu by go wnikliwie poprawiać.
W każdym razie u mnie działa (testowane na plikach mpg oraz avi)

0

Dzięki! Działa :-)

1 użytkowników online, w tym zalogowanych: 0, gości: 1