But when i try to use The same forms with the same files into a dll i only can read the device list and unable to Capture the camera
any idea why ?
Here is the full project code
Kod: Tümünü seç
unit Testcm;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, ufrmCam;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Cam :TfrmCam;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
if not Assigned(cam) then
begin
cam := TfrmCam.Create(self);
end;
cam.openWebCam;
cam.Show;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if Assigned(cam) then
begin
FreeAndNil(cam);
end;
end;
end.
Cam form
Kod: Tümünü seç
unit ufrmCam;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Controls, Forms,
Dialogs, Menus, ExtCtrls, StdCtrls, JvExStdCtrls, Graphics,
IniFiles, JPEG, VFrames, VSample, Direct3D9, DirectDraw, DirectShow9,
DirectSound, DXTypes,
Vcl.ComCtrls;
type
TfrmCam = class(TForm)
shp1: TShape;
img1: TImage;
lbl_camstatus: TLabel;
Button1: TButton;
cbb1: TComboBox;
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
formClosed: Boolean;
fVideoImage: TVideoImage;
fVideoBitmap: TBitmap;
fActivated: Boolean;
procedure OnNewVideoFrame(Sender: TObject; Width, Height: integer;
DataPtr: pointer);
procedure OnNewVideoCanvas(Sender: TObject; Width, Height: integer;
DataPtr: pointer);
public
{ Public declarations }
procedure openWebCam;
procedure closeWebCam;
procedure AddNick(Nick: String);
procedure RemoveNick(Nick: String);
end;
var
frmCam: TfrmCam;
implementation
{$R *.dfm}
procedure TfrmCam.RemoveNick(Nick: String);
begin
end;
procedure TfrmCam.AddNick(Nick: String);
begin
end;
procedure TfrmCam.Button1Click(Sender: TObject);
begin
if fActivated then
begin
fVideoImage.OnNewVideoFrame := OnNewVideoCanvas;
img1.Picture.Bitmap.Assign(fVideoBitmap);
end
else
begin
lbl_camstatus.Caption := 'Disconnected';
end;
end;
procedure TfrmCam.closeWebCam;
begin
end;
procedure TfrmCam.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
// CanClose := False;
// f.btnCamClick(nil);
end;
procedure TfrmCam.FormCreate(Sender: TObject);
var
DeviceList: Tstringlist;
begin
fVideoBitmap := TBitmap.create;
fActivated := false;
fVideoImage := TVideoImage.create;
DeviceList := Tstringlist.create;
fVideoImage.GetListOfDevices(DeviceList);
cbb1.Items := DeviceList;
DeviceList.Free;
cbb1.ItemIndex := 0;
end;
procedure TfrmCam.FormDestroy(Sender: TObject);
begin
try
fVideoImage.VideoStop;
except
end;
try
fVideoBitmap.Free;
except
end;
try
fVideoImage.Free;
except
end;
end;
procedure TfrmCam.FormShow(Sender: TObject);
begin
formClosed := false;
self.Width := self.Width + 1;
self.Height := self.Height + 1;
self.Width := self.Width - 1;
self.Height := self.Height - 1;
end;
{ TvideoForm }
procedure TfrmCam.OnNewVideoFrame(Sender: TObject; Width, Height: integer;
DataPtr: pointer);
begin
fVideoImage.GetBitmap(fVideoBitmap);
end;
procedure TfrmCam.OnNewVideoCanvas(Sender: TObject; Width, Height: integer;
DataPtr: pointer);
begin
fVideoImage.GetBitmap(fVideoBitmap);
// Pega o frame atual, Nمo sei pq mas precisa desta linha para funcionar.
img1.Picture.Bitmap.Canvas.Draw(0, 0, fVideoBitmap);
// Envia frame a frame de vيdeo para o componente TImage, tb nمo entendi direito o pq de sَ funcionar com o canvas, mas deu certo.
end;
procedure TfrmCam.openWebCam;
var
camdevice: string;
begin
camdevice := Trim(cbb1.Items.Strings[cbb1.ItemIndex]);
if camdevice <> '' then
begin
try
fVideoImage.VideoStart(camdevice);
fVideoImage.OnNewVideoFrame := OnNewVideoFrame;
fActivated := true;
lbl_camstatus.Caption := 'Connected';
lbl_camstatus.Font.Color := clGreen;
except
fActivated := false;
lbl_camstatus.Caption := 'Disconnected';
lbl_camstatus.Font.Color := clRed;
end;
lbl_camstatus.Caption := camdevice;
end;
end;
end.
Vframes
Kod: Tümünü seç
unit VFrames;
(******************************************************************************
VFrames.pas
Class TVideoImage
About
The TVideoImage class provides a simplified access to the class TVideoSample
from source unit VSample.pas.
It is used to access WebCams and similar Video-capture devices via DirectShow.
Its focus is on acquiring single images (frames) from the running video stream
sent by the cameras. There exist methods to control properties (e.g. size,
brightness etc.)
Acquisition is fast enough to simulate running video.
No audio support.
History
Version 1.4
Added support for YUY2 (YUYV, YUNV), MJPG, I420 (YV12, IYUV)
Version 1.3
07.09.2008
Added Video-Size and Video-property control
Added check for extreme CPU load
Version 1.2
30.08.2008
Added Pause and Resume
Version 1.1
26.07.2008
Contact:
michael@grizzlymotion.com
Copyright
For copyrights of the DirectX Header ports see the original source files.
Other code (unless stated otherwise, see comments): Copyright (C) M. Braun
Licence:
The lion share of this project lies within the ports of the DirectX header
files (which are under the Mozilla Public License Version 1.1), and the
original SDK sample files from Microsoft (END-USER LICENSE AGREEMENT FOR
MICROSOFT SOFTWARE DirectX 9.0 Software Development Kit Update (Summer 2003))
My own contribution compared to that work is very small (although it cost me
lots of time), but still is "significant enough" to fulfill Microsofts licence
agreement ;)
So I think, the ZLib licence (http://www.zlib.net/zlib_license.html)
should be sufficient for my code contributions.
Please note:
There exist much more complete alternatives (incl. sound, AVI etc.):
- DSPack (http://www.progdigy.com/)
- TVideoCapture by Egor Averchenkov (can be found at http://www.torry.net)
******************************************************************************)
interface
USES Windows, Messages, Controls, Forms, SysUtils, Graphics, Classes,
AppEvnts, MMSystem, DirectShow9, JPEG,
VSample;
CONST
CBufferCnt = 3;
TYPE
TNewVideoFrameEvent = procedure(Sender : TObject; Width, Height: integer; DataPtr: pointer) of object;
TVideoProperty = (VP_Brightness,
VP_Contrast,
VP_Hue,
VP_Saturation,
VP_Sharpness,
VP_Gamma,
VP_ColorEnable,
VP_WhiteBalance,
VP_BacklightCompensation,
VP_Gain);
TVideoImage = class
private
VideoSample : TVideoSample;
OnNewFrameBusy: boolean;
fVideoRunning : boolean;
fBusy : boolean;
fSkipCnt : integer;
fFrameCnt : integer;
f30FrameTick : cardinal;
fFPS : double; // "Real" fps, even if not all frames will be displayed.
fWidth,
fHeight : integer;
fFourCC : cardinal;
fBitmap : TBitmap;
fDisplayCanvas: TCanvas;
fImagePtr : ARRAY[0..CBufferCnt] OF pointer; // Local copy of image data
fImagePtrSize : ARRAY[0..CBufferCnt] OF integer;
fImagePtrIndex: integer;
fMessageHWND : HWND;
fMsgNewFrame : uint;
fOnNewFrame : TNewVideoFrameEvent;
AppEvent : TApplicationEvents;
IdleEventTick : cardinal;
ValueY_298,
ValueU_100,
ValueU_516,
ValueV_409,
ValueV_208 : ARRAY[byte] OF integer;
ValueClip : ARRAY[-1023..1023] OF byte;
fYUY2TablesPrepared : boolean;
JPG : TJPEGImage;
MemStream : TMemoryStream;
fImageUnpacked: boolean;
procedure PaintFrame;
procedure UnpackFrame(Size: integer; pData: pointer);
procedure WndProc(var Msg: TMessage);
function VideoSampleIsPaused: boolean;
procedure AppEventsIdle(Sender: TObject; var Done: Boolean);
procedure CallBack(pb : pbytearray; var Size: integer);
function TranslateProperty(const VP: TVideoProperty; VAR VPAP: TVideoProcAmpProperty): HResult;
PROCEDURE PrepareTables;
procedure YUY2_to_RGB(pData: pointer);
procedure I420_to_RGB(pData: pointer);
public
constructor Create;
destructor Destroy; override;
procedure Free;
property IsPaused: boolean read VideoSampleIsPaused;
property VideoRunning : boolean read fVideoRunning;
property VideoWidth: integer read fWidth;
property VideoHeight: integer read fHeight;
property OnNewVideoFrame : TNewVideoFrameEvent read fOnNewFrame write fOnNewFrame;
property FramesPerSecond: double read fFPS;
property FramesSkipped: integer read fSkipCnt;
procedure GetListOfDevices(DeviceList: TStringList);
procedure VideoStop;
procedure VideoPause;
procedure VideoResume;
function VideoStart(DeviceName: string): integer;
procedure GetBitmap(BMP: TBitmap);
procedure SetDisplayCanvas(Canvas: TCanvas);
procedure ShowProperty;
procedure ShowProperty_Stream;
FUNCTION ShowVfWCaptureDlg: HResult;
procedure GetBrightnessSettings(VAR Actual: integer);
procedure SetBrightnessSettings(const Actual: integer);
PROCEDURE GetListOfSupportedVideoSizes(VidSize: TStringList);
PROCEDURE SetResolutionByIndex(Index: integer);
FUNCTION GetVideoPropertySettings( VP : TVideoProperty;
VAR MinVal, MaxVal,
StepSize, Default,
Actual : integer;
VAR AutoMode: boolean): HResult;
FUNCTION SetVideoPropertySettings(VP: TVideoProperty; Actual: integer; AutoMode: boolean): HResult;
end;
FUNCTION GetVideoPropertyName(VP: TVideoProperty): string;
// http://www.fourcc.org/yuv.php#UYVY
CONST
FourCC_YUY2 = $32595559;
FourCC_YUYV = $56595559;
FourCC_YUNV = $564E5559;
FourCC_MJPG = $47504A4D;
FourCC_I420 = $30323449;
FourCC_YV12 = $32315659;
FourCC_IYUV = $56555949;
implementation
FUNCTION GetVideoPropertyName(VP: TVideoProperty): string;
BEGIN
CASE VP OF
VP_Brightness : Result := 'Brightness';
VP_Contrast : Result := 'Contrast';
VP_Hue : Result := 'Hue';
VP_Saturation : Result := 'Saturation';
VP_Sharpness : Result := 'Sharpness';
VP_Gamma : Result := 'Gamma';
VP_ColorEnable : Result := 'ColorEnable';
VP_WhiteBalance : Result := 'WhiteBalance';
VP_BacklightCompensation: Result := 'Backlight';
VP_Gain : Result := 'Gain';
END; {case}
END;
(* Finally, callback seems to work. Previously it only ran for a few seconds.
The reason for that seemed to be a deadlock (see http://msdn.microsoft.com/en-us/library/ms786692(VS.85).aspx)
Now the image data is copied immediatly, and a message is sent to invoke the
display of the data. *)
procedure TVideoImage.CallBack(pb : pbytearray; var Size: integer);
var
i : integer;
T1 : cardinal;
begin
Inc(fFrameCnt);
// Calculate "Frames per second"...
T1 := TimeGetTime;
IF fFrameCnt mod 30 = 0 then
begin
if f30FrameTick > 0 then
fFPS := 30000 / (T1-f30FrameTick);
f30FrameTick := T1;
end;
// Does the application run in unhealthy CPU usage?
// Check, if no idle event has occured for at least 1 sec.
// If so, skip current frame and give application time to "breathe".
IF Abs(T1-IdleEventTick) > 1000 then
begin
Inc(fSkipCnt);
exit;
end;
// Adjust pointer to image data if necessary
i := (fImagePtrIndex+1) mod CBufferCnt;
IF fImagePtrSize[i] <> Size then
begin
IF fImagePtrSize[i] > 0 then
FreeMem(fImagePtr[i], fImagePtrSize[i]);
fImagePtrSize[i] := Size;
GetMem(fImagePtr[i], fImagePtrSize[i]);
end;
// Save image data to local memory
move(pb^, fImagePtr[i]^, Size);
fImagePtrIndex := i;
fImageUnpacked := false;
// This routine is called by the video software and therefore runs within their thread.
// Posting a message to our own HWND will transport the information to the main thread.
PostMessage(fMessageHWND, fMsgNewFrame, Size, integer(fImagePtr[i]));
sleep(0);
end;
// Own windows message handler only to get the "New Video Frame has arrived" message.
// Used to get the information out of the Camera-Thread into the application's thread.
// Otherwise we would run into a deadlock.
procedure TVideoImage.WndProc(var Msg: TMessage);
begin
with Msg do
if Msg = fMsgNewFrame then
try
IF not fBusy then
begin
fBusy := true;
fImageUnpacked := false;
PaintFrame; // If a Display-Canvas has been set, paint video image on it.
IF assigned(fOnNewFrame) then
fOnNewFrame(self, fWidth, fHeight, fImagePtr[fImagePtrIndex]);
fBusy := false;
end
else Inc(fSkipCnt);
except
Application.HandleException(Self);
fBusy := false;
end
else Result := DefWindowProc(fMessageHWND, Msg, wParam, lParam);
end;
constructor TVideoImage.Create;
VAR
i : integer;
begin
inherited Create;
fVideoRunning := false;
OnNewFrameBusy := false;
fBitmap := TBitmap.Create;
fDisplayCanvas := nil;
fWidth := 0;
fHeight := 0;
fFourCC := 0;
FOR i := 0 TO CBufferCnt-1 DO
BEGIN
fImagePtr[i] := nil;
fImagePtrSize[i] := 0;
END;
fMsgNewFrame := wm_user+662;
fOnNewFrame := nil;
fBusy := false;
// Create a HWND that can capture some messages for us...
fMessageHWND := AllocateHWND(WndProc);
AppEvent := TApplicationEvents.Create(Application.MainForm);
AppEvent.OnIdle := AppEventsIdle;
JPG := TJPEGImage.Create;
MemStream := TMemoryStream.Create;
end;
// Check, when the last OnIdle message arrived. Save a time stamp.
// Used to check the CPU load. If necessary, we will skip video frames...
procedure TVideoImage.AppEventsIdle(Sender: TObject; var Done: Boolean);
begin
IdleEventTick := TimeGetTime;
Done := true;
end;
destructor TVideoImage.Destroy;
VAR
i : integer;
begin
FOR i := CBufferCnt-1 DOWNTO 0 DO
IF fImagePtrSize[i] <> 0 then
begin
FreeMem(fImagePtr[i], fImagePtrSize[i]);
fImagePtr[i] := nil;
fImagePtrSize[i] := 0;
end;
DeallocateHWnd(fMessageHWND);
inherited Destroy;
end;
procedure TVideoImage.Free;
begin
fDisplayCanvas := nil;
fBitmap.Free;
AppEvent.OnIdle := nil;
AppEvent.Free;
AppEvent := nil;
inherited Free;
end;
// For Properties see also http://msdn.microsoft.com/en-us/library/ms786938(VS.85).aspx
function TVideoImage.TranslateProperty(const VP: TVideoProperty; VAR VPAP: TVideoProcAmpProperty): HResult;
begin
Result := S_OK;
CASE VP OF
VP_Brightness : VPAP := VideoProcAmp_Brightness;
VP_Contrast : VPAP := VideoProcAmp_Contrast;
VP_Hue : VPAP := VideoProcAmp_Hue;
VP_Saturation : VPAP := VideoProcAmp_Saturation;
VP_Sharpness : VPAP := VideoProcAmp_Sharpness;
VP_Gamma : VPAP := VideoProcAmp_Gamma;
VP_ColorEnable : VPAP := VideoProcAmp_ColorEnable;
VP_WhiteBalance : VPAP := VideoProcAmp_WhiteBalance;
VP_BacklightCompensation : VPAP := VideoProcAmp_BacklightCompensation;
VP_Gain : VPAP := VideoProcAmp_Gain;
else Result := S_False;
END; {case}
end;
FUNCTION TVideoImage.GetVideoPropertySettings(VP: TVideoProperty; VAR MinVal, MaxVal, StepSize, Default, Actual: integer; VAR AutoMode: boolean): HResult;
VAR
VPAP : TVideoProcAmpProperty;
pCapsFlags : TVideoProcAmpFlags;
BEGIN
Result := S_FALSE;
MinVal := -1;
MaxVal := -1;
StepSize := 0;
Default := 0;
Actual := 0;
AutoMode := true;
IF not(assigned(VideoSample)) or Failed(TranslateProperty(VP, VPAP)) then
exit;
Result := TranslateProperty(VP, VPAP);
IF Failed(Result) then
exit;
Result := VideoSample.GetVideoPropAmpEx(VPAP, MinVal, MaxVal, StepSize, Default, pCapsFlags, Actual);
IF Failed(Result) then
begin
MinVal := -1;
MaxVal := -1;
StepSize := 0;
Default := 0;
Actual := 0;
AutoMode := true;
end
else begin
AutoMode := pCapsFlags <> VideoProcAmp_Flags_Manual;
end;
END;
FUNCTION TVideoImage.SetVideoPropertySettings(VP: TVideoProperty; Actual: integer; AutoMode: boolean): HResult;
VAR
VPAP : TVideoProcAmpProperty;
pCapsFlags : TVideoProcAmpFlags;
BEGIN
Result := TranslateProperty(VP, VPAP);
IF not(assigned(VideoSample)) or Failed(Result) then
exit;
IF AutoMode
then pCapsFlags := VideoProcAmp_Flags_Auto
else pCapsFlags := VideoProcAmp_Flags_Manual;
Result := VideoSample.SetVideoPropAmpEx(VPAP, pCapsFlags, Actual);
END;
procedure TVideoImage.GetListOfDevices(DeviceList: TStringList);
begin
GetCaptureDeviceList(DeviceList);
end;
procedure TVideoImage.VideoPause;
begin
if not assigned(VideoSample) then
exit;
VideoSample.PauseVideo;
end;
procedure TVideoImage.VideoResume;
begin
if not assigned(VideoSample) then
exit;
VideoSample.ResumeVideo;
end;
procedure TVideoImage.VideoStop;
begin
fFPS := 0;
if not assigned(VideoSample) then
exit;
try
VideoSample.Free;
VideoSample := nil;
except
end;
fVideoRunning := false;
end;
function TVideoImage.VideoStart(DeviceName: string): integer;
VAR
hr : HResult;
st : string;
W, H : integer;
FourCC : cardinal;
begin
fSkipCnt := 0;
fFrameCnt := 0;
f30FrameTick := 0;
fFPS := 0;
fImageUnpacked := false;
Result := 0;
if assigned(VideoSample) then
VideoStop;
VideoSample := TVideoSample.Create(Application.MainForm.Handle, false, 0, HR); // No longer force RGB24
try
hr := VideoSample.StartVideo(DeviceName, false, st) // Not visible. Displays itself...
except
hr := -1;
end;
if Failed(hr)
then begin
VideoStop;
// SpeedButton_RunVideo.Down := false;
// ShowMessage(DXGetErrorDescription9A(hr));
Result := 1;
end
else begin
hr := VideoSample.GetStreamInfo(W, H, FourCC);
IF Failed(HR)
then begin
VideoStop;
Result := 1;
end
else BEGIN
fWidth := W;
fHeight := H;
fFourCC := FourCC;
FBitmap.PixelFormat := pf24bit;
FBitmap.Width := W;
FBitmap.Height := H;
VideoSample.SetCallBack(CallBack); // Do not call GDI routines in Callback!
END;
end;
end;
function TVideoImage.VideoSampleIsPaused: boolean;
begin
if assigned(VideoSample)
then Result := VideoSample.PlayState = PS_PAUSED
else Result := false;
end;
PROCEDURE TVideoImage.PrepareTables;
VAR
i : integer;
BEGIN
IF fYUY2TablesPrepared then
exit;
FOR i := 0 TO 255 DO
BEGIN
{ http://msdn.microsoft.com/en-us/library/ms893078.aspx
ValueY_298[i] := (i- 16) * 298 + 128; // -4640 .. 71350
ValueU_100[i] := (i-128) * 100; // -12800 .. 12700
ValueU_516[i] := (i-128) * 516; // -66048 .. 65532
ValueV_409[i] := (i-128) * 409; // -52352 .. 51943
ValueV_208[i] := (i-128) * 208; // -26624 .. 26416
}
// http://en.wikipedia.org/wiki/YCbCr (ITU-R BT.601)
ValueY_298[i] := round(i * 298.082);
ValueU_100[i] := round(i * -100.291);
ValueU_516[i] := round(i * 516.412 - 276.836*256);
ValueV_409[i] := round(i * 408.583 - 222.921*256);
ValueV_208[i] := round(i * -208.120 + 135.576*256);
END;
FillChar(ValueClip, SizeOf(ValueClip), #0);
FOR i := 0 TO 255 DO
ValueClip[i] := i;
FOR i := 256 TO 1023 DO
ValueClip[i] := 255;
fYUY2TablesPrepared := true;
END;
procedure TVideoImage.I420_to_RGB(pData: pointer);
// http://en.wikipedia.org/wiki/YCbCr
VAR
L, X, Y : integer;
ps : pbyte;
pY, pU, pV : pbyte;
begin
pY := pData;
PrepareTables;
FOR Y := 0 TO fBitmap.Height-1 DO
BEGIN
ps := fBitmap.ScanLine[Y];
pU := pData;
Inc(pU, fBitmap.Width*(fBitmap.height+ Y div 4));
pV := PU;
Inc(pV, fBitmap.Width*fBitmap.height div 4);
FOR X := 0 TO (fBitmap.Width div 2)-1 DO
begin
L := ValueY_298[pY^];
ps^ := ValueClip[(L + ValueU_516[pU^] ) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueU_100[pU^] + ValueV_208[pV^]) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueV_409[pV^]) div 256];
Inc(ps);
Inc(pY);
L := ValueY_298[pY^];
ps^ := ValueClip[(L + ValueU_516[pU^] ) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueU_100[pU^] + ValueV_208[pV^]) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueV_409[pV^]) div 256];
Inc(ps);
Inc(pY);
Inc(pU);
Inc(pV);
end;
END;
end;
procedure TVideoImage.YUY2_to_RGB(pData: pointer);
// http://msdn.microsoft.com/en-us/library/ms893078.aspx
// http://en.wikipedia.org/wiki/YCbCr
type
TFour = ARRAY[0..3] OF byte;
VAR
L, X, Y : integer;
ps : pbyte;
pf : ^TFour;
begin
pf := pData;
PrepareTables;
FOR Y := 0 TO fBitmap.Height-1 DO
BEGIN
ps := fBitmap.ScanLine[Y];
FOR X := 0 TO (fBitmap.Width div 2)-1 DO
begin
L := ValueY_298[pf^[0]];
ps^ := ValueClip[(L + ValueU_516[pf^[1]] ) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueU_100[pf^[1]] + ValueV_208[pf^[3]]) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueV_409[pf^[3]]) div 256];
Inc(ps);
L := ValueY_298[pf^[2]];
ps^ := ValueClip[(L + ValueU_516[pf^[1]] ) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueU_100[pf^[1]] + ValueV_208[pf^[3]]) div 256];
Inc(ps);
ps^ := ValueClip[(L + ValueV_409[pf^[3]]) div 256];
Inc(ps);
Inc(pf);
end;
END;
end;
procedure TVideoImage.PaintFrame;
BEGIN
// Paint FBitmap to fDisplayCanvas, if available
if assigned(fDisplayCanvas) then
begin
IF not fImageUnpacked then
UnpackFrame(fImagePtrSize[fImagePtrIndex], fImagePtr[fImagePtrIndex]);
IF fDisplayCanvas.LockCount < 1 then
begin
fDisplayCanvas.lock;
try
fDisplayCanvas.Draw(0, 0, fBitmap);
finally
fDisplayCanvas.unlock;
end;
end;
end;
END;
procedure TVideoImage.UnpackFrame(Size: integer; pData: pointer);
var
{f : file;}
Unknown : boolean;
FourCCSt: string[4];
begin
IF pData = nil
then exit;
Unknown := false;
try
Case fFourCC OF
0 : BEGIN
IF (Size = fWidth*fHeight*3)
then move(pData^, FBitmap.scanline[fHeight-1]^, Size)
else Unknown := true;
END;
FourCC_YUY2,
FourCC_YUYV,
FourCC_YUNV : BEGIN
IF (Size = fWidth*fHeight*2)
then YUY2_to_RGB(pData)
else Unknown := true;
END;
FourCC_MJPG : BEGIN
try
MemStream.Clear;
MemStream.SetSize(Size);
MemStream.Position := 0;
MemStream.WriteBuffer(pData^, Size);
MemStream.Position := 0;
JPG.LoadFromStream(MemStream);
FBitmap.Canvas.Draw(0, 0, JPG);
except
Unknown := true;
end;
END;
FourCC_I420,
FourCC_YV12,
FourCC_IYUV : BEGIN
IF (Size = (fWidth*fHeight*3) div 2)
then I420_to_RGB(pData)
else Unknown := true;
END;
else BEGIN
{
assignfile(f, 'Unknown_Frame.dat');
rewrite(f, 1);
Blockwrite(f, pData^, Size);
closefile(f);
}
Unknown := true;
END;
end; {case}
IF Unknown then
begin
IF fFourCC = 0
then FourCCSt := 'RGB'
else begin
FourCCSt := ' ';
move(fFourCC, FourCCSt[1], 4);
end;
FBitmap.Canvas.TextOut(0, 0, 'Unknown compression');
FBitmap.Canvas.TextOut(0, FBitmap.Canvas.TextHeight('X'), 'DataSize: '+INtToStr(Size)+' FourCC: '+FourCCSt);
end;
fImageUnpacked := true;
except
end;
end;
procedure TVideoImage.GetBitmap(BMP: TBitmap);
begin
IF not fImageUnpacked then
UnpackFrame(fImagePtrSize[fImagePtrIndex], fImagePtr[fImagePtrIndex]);
BMP.Assign(fBitmap);
(*
BMP.PixelFormat := pf24bit;
BMP.Width := fBitmap.Width;
BMP.Height := fBitmap.Height;
move(fBitmap.ScanLine[fBitmap.Height-1]^, BMP.ScanLine[BMP.height-1]^, BMP.Height*BMP.Width*3);
//BMP.Canvas.Draw(0, 0, fBitmap);
*)
end;
procedure TVideoImage.SetDisplayCanvas(Canvas: TCanvas);
begin
fDisplayCanvas := Canvas;
end;
procedure TVideoImage.ShowProperty;
begin
VideoSample.ShowPropertyDialog;
end;
procedure TVideoImage.ShowProperty_Stream;
var
hr : HResult;
W, H : integer;
FourCC : cardinal;
begin
VideoSample.ShowPropertyDialog_CaptureStream;
hr := VideoSample.GetStreamInfo(W, H, FourCC);
IF Failed(HR)
then begin
VideoStop;
end
else BEGIN
fWidth := W;
fHeight := H;
fFourCC := FourCC;
FBitmap.PixelFormat := pf24bit;
FBitmap.Width := W;
FBitmap.Height := H;
VideoSample.SetCallBack(CallBack);
END;
end;
FUNCTION TVideoImage.ShowVfWCaptureDlg: HResult;
begin
Result := VideoSample.ShowVfWCaptureDlg;
end;
procedure TVideoImage.GetBrightnessSettings(VAR Actual: integer);
begin
// VideoSample.GetVideoPropAmp(VideoProcAmp_Brightness, Actual)
end;
procedure TVideoImage.SetBrightnessSettings(const Actual: integer);
begin
// VideoSample.SetVideoPropAmp(VideoProcAmp_Brightness, Actual);
end;
PROCEDURE TVideoImage.GetListOfSupportedVideoSizes(VidSize: TStringList);
BEGIN
VideoSample.GetListOfVideoSizes(VidSize);
END;
PROCEDURE TVideoImage.SetResolutionByIndex(Index: integer);
VAR
hr : HResult;
W, H : integer;
FourCC : cardinal;
BEGIN
VideoSample.SetVideoSizeByListIndex(Index);
hr := VideoSample.GetStreamInfo(W, H, FourCC);
IF Succeeded(HR)
then begin
fWidth := W;
fHeight := H;
fFourCC := FourCC;
FBitmap.PixelFormat := pf24bit;
FBitmap.Width := W;
FBitmap.Height := H;
END;
END;
end.