W jaki sposób mogę sprowadzić do TBitmap zrzut wykonany procedurą GetCurrentImage w IBasicVideo?
Pomoże ktooooooś??
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
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.....
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)
Dzięki! Działa :-)