unit VFrames;(******************************************************************************VFrames.pasClass TVideoImageAboutThe TVideoImage class provides a simplified access to the class TVideoSamplefrom 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 streamsent by the cameras. There exist methods to control properties (e.g. size,brightness etc.)Acquisition usually is fast enough to simulate running video.No audio support.HistoryVersion 1.62012-07-09Support for 8-bit Grayscale images. Reduces time for image expansion for some typesof compressions. (But not for all, e.g. RGB!)Some memory leaks fixed.Version 1.5GDI+ support for MJPG, if GDI+ availableYUY2 relaxed check of data size to support 1280*720 video size for Microsoft LifeCam CinemaVersion 1.4Added support for YUY2 (YUYV, YUNV), MJPG, I420 (YV12, IYUV)Version 1.307.09.2008Added Video-Size and Video-property controlAdded check for extreme CPU loadVersion 1.230.08.2008Added Pause and ResumeVersion 1.126.07.2008Contact:michael@grizzlymotion.comCopyrightFor copyrights of the DirectX Header ports see the original source files.Other code (unless stated otherwise, see comments): Copyright (C) M. BraunLicence:The lion share of this project lies within the ports of the DirectX headerfiles (which are under the Mozilla Public License Version 1.1), and theoriginal SDK sample files from Microsoft (END-USER LICENSE AGREEMENT FORMICROSOFT SOFTWARE DirectX 9.0 Software Development Kit Update (Summer 2003))My own contribution compared to that work is very small (although it cost melots of time), but still is "significant enough" to fulfill Microsofts licenceagreement ;)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)******************************************************************************)interfaceUSES Windows, Messages, Controls, Forms, SysUtils, Graphics, Classes,AppEvnts, MMSystem, DirectShow9, JPEG, Math,VSample;CONSTCBufferCnt = 3;  // Triple-Buffer

TYPETNewVideoFrameEvent = 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 = classprivateVideoSample   : TVideoSample;OnNewFrameBusy: boolean;fVideoRunning : boolean;fBusy         : boolean;fGray8Bit    : 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;fBitmapGray   : TBitmap;fDisplayCanvas: TCanvas;fImagePtr     : ARRAY[0..CBufferCnt] OF pointer; // Local copy of image datafImagePtrSize : 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;ValueL_255    : ARRAY[byte] OF byte;ValueClip     : ARRAY[-1023..1023] OF byte;GrayConvR,GrayConvG,GrayConvB     : ARRAY[0..255] OF integer;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     PrepareGrayBMP(VAR BM : TBitmap; W, H: integer);PROCEDURE     PrepareTables;procedure     YUY2_to_RGB(pData: pointer);procedure     YUY2_to_Gray8Bit(pData: pointer);procedure     I420_to_RGB(pData: pointer);procedure     I420_to_Gray8Bit(pData: pointer);procedure     RGB_to_Gray8Bit(pData: pointer);publicconstructor   Create;destructor    Destroy; override;property      IsPaused: boolean read VideoSampleIsPaused;property      VideoRunning : boolean read fVideoRunning;property      VideoWidth: integer read fWidth;property      VideoHeight: integer read fHeight;property      Gray8Bit: boolean read fGray8Bit write fGray8Bit;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;PROCEDURE     Convert24ToGray(BM24: TBitmap; BMGray: TBitmap);end;FUNCTION GetVideoPropertyName(VP: TVideoProperty): string;// http://www.fourcc.org/yuv.php#UYVY

CONSTFourCC_YUY2 = $32595559;FourCC_YUYV = $56595559;FourCC_YUNV = $564E5559;FourCC_MJPG = $47504A4D;FourCC_I420 = $30323449;FourCC_YV12 = $32315659;FourCC_IYUV = $56555949;implementationFUNCTION GetVideoPropertyName(VP: TVideoProperty): string;
BEGINCASE VP OFVP_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 thedisplay of the data. *)
procedure TVideoImage.CallBack(pb : pbytearray; var Size: integer);
vari  : integer;T1 : cardinal;
beginInc(fFrameCnt);// Calculate "Frames per second"...T1 := TimeGetTime;IF fFrameCnt mod 30 = 0 thenbeginif f30FrameTick > 0 thenfFPS := 30000 / (T1-f30FrameTick);f30FrameTick := T1;end;// frt auf Windows 7 zu unendlich kleinen Frameraten! -cm
{// 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 thenbeginInc(fSkipCnt);exit;end;
}// Adjust pointer to image data if necessaryi := (fImagePtrIndex+1) mod CBufferCnt;IF fImagePtrSize[i] <> Size thenbeginIF fImagePtrSize[i] > 0 thenFreeMem(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);
beginwith Msg doif Msg = fMsgNewFrame thentryIF not fBusy thenbeginfBusy := true;fImageUnpacked := false;PaintFrame; // If a Display-Canvas has been set, paint video image on it.IF assigned(fOnNewFrame) thenfOnNewFrame(self, fWidth, fHeight, fImagePtr[fImagePtrIndex]);fBusy := false;endelse Inc(fSkipCnt);exceptApplication.HandleException(Self);fBusy := false;endelse Result := DefWindowProc(fMessageHWND, Msg, wParam, lParam);
end;constructor TVideoImage.Create;
VARi : integer;
begininherited Create;fVideoRunning   := false;OnNewFrameBusy  := false;fBitmap         := TBitmap.Create;fBitmapGray     := TBitmap.Create;fDisplayCanvas  := nil;fWidth          := 0;fHeight         := 0;fFourCC         := 0;FOR i := 0 TO CBufferCnt-1 DOBEGINfImagePtr[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;
//  JPG.Performance := jpBestSpeed;MemStream       := TMemoryStream.Create;fGray8Bit := false;FOR i := 0 TO 255 DOBEGINGrayConvR[i] := 100 * i;GrayConvG[i] := 128 * i;GrayConvB[i] :=  28 * i  +127;END;PrepareTables;
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);
beginIdleEventTick := TimeGetTime;Done := true;
end;destructor  TVideoImage.Destroy;
VARi : integer;
beginFOR i := CBufferCnt-1 DOWNTO 0 DOIF fImagePtrSize[i] <> 0 thenbeginFreeMem(fImagePtr[i], fImagePtrSize[i]);fImagePtr[i] := nil;fImagePtrSize[i] := 0;end;DeallocateHWnd(fMessageHWND);fDisplayCanvas := nil;fBitmapGray.Free;fBitmap.Free;JPG.Free;AppEvent.OnIdle := nil;AppEvent.Free;AppEvent := nil;MemStream.Free;inherited Destroy;
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;
beginResult := S_OK;CASE VP OFVP_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;
VARVPAP       : TVideoProcAmpProperty;pCapsFlags : TVideoProcAmpFlags;
BEGINResult   := S_FALSE;MinVal   := -1;MaxVal   := -1;StepSize := 0;Default  := 0;Actual   := 0;AutoMode := true;IF not(assigned(VideoSample)) or Failed(TranslateProperty(VP, VPAP)) thenexit;Result := TranslateProperty(VP, VPAP);IF Failed(Result) thenexit;Result := VideoSample.GetVideoPropAmpEx(VPAP, MinVal, MaxVal, StepSize, Default, pCapsFlags, Actual);IF Failed(Result) thenbeginMinVal   := -1;MaxVal   := -1;StepSize := 0;Default  := 0;Actual   := 0;AutoMode := true;endelse beginAutoMode := pCapsFlags <> VideoProcAmp_Flags_Manual;end;
END;FUNCTION TVideoImage.SetVideoPropertySettings(VP: TVideoProperty; Actual: integer; AutoMode: boolean): HResult;
VARVPAP       : TVideoProcAmpProperty;pCapsFlags : TVideoProcAmpFlags;
BEGINResult := TranslateProperty(VP, VPAP);IF not(assigned(VideoSample)) or Failed(Result) thenexit;IF AutoModethen pCapsFlags := VideoProcAmp_Flags_Autoelse pCapsFlags := VideoProcAmp_Flags_Manual;Result := VideoSample.SetVideoPropAmpEx(VPAP, pCapsFlags, Actual);
END;procedure TVideoImage.GetListOfDevices(DeviceList: TStringList);
beginGetCaptureDeviceList(DeviceList);
end;procedure TVideoImage.VideoPause;
beginif not assigned(VideoSample) thenexit;VideoSample.PauseVideo;
end;procedure TVideoImage.VideoResume;
beginif not assigned(VideoSample) thenexit;VideoSample.ResumeVideo;
end;procedure TVideoImage.VideoStop;
beginfFPS := 0;if not assigned(VideoSample) thenexit;tryVideoSample.Free;VideoSample := nil;exceptend;fVideoRunning := false;
end;function TVideoImage.VideoStart(DeviceName: string): integer;
VARhr     : HResult;st     : string;W, H   : integer;FourCC : cardinal;
beginfSkipCnt       := 0;fFrameCnt      := 0;f30FrameTick   := 0;fFPS           := 0;fImageUnpacked := false;Result := 0;if assigned(VideoSample) thenVideoStop;VideoSample := TVideoSample.Create(Application.MainForm.Handle, false, 0, HR); // No longer force RGB24tryhr := VideoSample.StartVideo(DeviceName, false, st) // Not visible. Displays itself...excepthr := -1;end;if Failed(hr)then beginVideoStop;// ShowMessage(DXGetErrorDescription9A(hr));Result := 1;endelse beginhr := VideoSample.GetStreamInfo(W, H, FourCC);IF Failed(HR)then beginVideoStop;Result := 1;endelse BEGINfWidth := W;fHeight := H;fFourCC := FourCC;FBitmap.PixelFormat := pf24bit;FBitmap.Width := W;FBitmap.Height := H;PrepareGrayBMP(FBitmapGray, W, H);VideoSample.SetCallBack(CallBack);  // Do not call GDI routines in Callback!
        END;end;
end;function TVideoImage.VideoSampleIsPaused: boolean;
beginif assigned(VideoSample)then Result := VideoSample.PlayState = PS_PAUSEDelse Result := false;
end;// Create an 8bit grayscale palette image with width W and Height H.
PROCEDURE TVideoImage.PrepareGrayBMP(VAR BM : TBitmap; W, H: integer);
TYPETLogPal =  packed recordpalVersion: Word;palNumEntries: Word;palPalEntry: array[0..255] of TPaletteEntry;  // In contrast to original declaration uses 255 instead of 0end;
VARPal  : TLogPal;_Pal : tagLogPalette absolute Pal;  // Trick! ;)
  dw   : LongWord;
BEGINWITH Pal DOBEGINpalVersion:=$300;palNumEntries:=256;FOR dw := 0 TO 255 DOpalPalEntry[dw] := TPaletteEntry(dw * $010101);END;BM.width := W;BM.Height := H;BM.Transparent := false;BM.pixelformat := pf8bit;BM.Palette := CreatePalette(_Pal);
END; {PrepareGrayBMP}PROCEDURE TVideoImage.Convert24ToGray(BM24: TBitmap; BMGray: TBitmap);
{ - Convert a 24bit RGB bitmap into a 8bit grayscale image }
//type
//  tbytearray = ARRAY[0..16387] OF byte;
//  pbytearray = ^tbytearray;
//VAR
//  p24, p8  : pbytearray;
//  X, Y, X3 : integer;
BEGINIF BM24.PixelFormat = pf8bit thenbeginBMGray.assign(BM24);exit;end;if (BM24.Width <> BMGray.Width) or (BM24.Height <> BMGray.Height) or (BMGray.PixelFormat <> pf8bit) thenPrepareGrayBMP(BMGray, BM24.Width, bm24.Height);{  This is the do-it-yourself way of converting RGB to GrayScale:FOR Y := BM24.height-1 DOWNTO 0 dobeginp24 := BM24.ScanLine[Y];p8  := BMGray.ScanLine[Y];X3 := 0;FOR X := 0 TO BMGray.Width-1 DObeginp8^[X] := (GrayConvB[p24^[X3]] + GrayConvG[p24^[X3+1]] + GrayConvR[p24^[X3+2]]) div 256;Inc(X3, 3);end;end;}BMGray.Canvas.Draw(0, 0, BM24);
END;PROCEDURE TVideoImage.PrepareTables;
VARi : integer;
BEGINIF fYUY2TablesPrepared thenexit;FOR i := 0 TO 255 DOBEGIN{ http://msdn.microsoft.com/en-us/library/ms893078.aspxValueY_298[i] := (i- 16) * 298  +  128;      //  -4640 .. 71350ValueU_100[i] := (i-128) * 100;              // -12800 .. 12700ValueU_516[i] := (i-128) * 516;              // -66048 .. 65532ValueV_409[i] := (i-128) * 409;              // -52352 .. 51943ValueV_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);ValueL_255[i] := Min(255, round(i *  298.082 / 255));END;FillChar(ValueClip, SizeOf(ValueClip), #0);FOR i := 0 TO 255 DOValueClip[i] := i;FOR i := 256 TO 1023 DOValueClip[i] := 255;fYUY2TablesPrepared := true;
END;procedure TVideoImage.I420_to_RGB(pData: pointer);
// http://en.wikipedia.org/wiki/YCbCr
VARL, X, Y    : integer;ps         : pbyte;pY, pU, pV : pbyte;
beginpY := pData;PrepareTables;FOR Y := 0 TO fBitmap.Height-1 DOBEGINps := 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 DObeginL := 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.I420_to_Gray8Bit(pData: pointer);
// http://en.wikipedia.org/wiki/YCbCr
varY  : integer;pY : pbyte;
beginpY := pData;FOR Y := 0 TO fBitmapGray.Height-1 DObeginmove(pY^, fBitmapGray.ScanLine[Y]^, fBitmapGray.Width);Inc(pY, fBitmapGray.Width);end;
end;procedure TVideoImage.YUY2_to_RGB(pData: pointer);
// http://msdn.microsoft.com/en-us/library/ms893078.aspx
// http://en.wikipedia.org/wiki/YCbCr
typeTFour  = ARRAY[0..3] OF byte;
VARL, X, Y : integer;ps      : pbyte;pf      : ^TFour;
beginpf := pData;PrepareTables;FOR Y := 0 TO fBitmap.Height-1 DOBEGINps := fBitmap.ScanLine[Y];FOR X := 0 TO (fBitmap.Width div 2)-1 DObeginL := 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.YUY2_to_Gray8Bit(pData: pointer);
// http://msdn.microsoft.com/en-us/library/ms893078.aspx
// http://en.wikipedia.org/wiki/YCbCr
typeTFour  = ARRAY[0..3] OF byte;
VARX, Y : integer;ps   : pbyte;pf   : ^byte;
beginpf := pData;FOR Y := 0 TO fBitmapGray.Height-1 DOBEGINps := fBitmapGray.ScanLine[Y];FOR X := 0 TO (fBitmapGray.Width div 2)-1 DObeginps^ := pf^;Inc(ps);Inc(pf, 2);ps^ := pf^;Inc(ps);Inc(pf, 2);end;END;
end;procedure TVideoImage.RGB_to_Gray8Bit(pData: pointer);
typeTRGB       = ARRAY[0..5] OF byte;TPTRGB     = ^TRGB;TWordArr   = ARRAY[0..5759] OF word;TPTWordArr = ^TWordArr;
VARX, Y : integer;p8   : TPTWordArr;pf   : TPTRGB;
beginpf := pData;FOR Y := fBitmapGray.height-1 DOWNTO 0 dobeginp8  := fBitmapGray.ScanLine[Y];FOR X := 0 TO fBitmapGray.Width div 2-1 DObeginp8^[X] := ((GrayConvB[pf^[3]] + GrayConvG[pf^[4]] + GrayConvR[pf^[5]]) and $FF00) +(GrayConvB[pf^[0]] + GrayConvG[pf^[1]] + GrayConvR[pf^[2]]) shr 8;Inc(pf);end;end;end;procedure TVideoImage.PaintFrame;
BEGIN// Paint FBitmap to fDisplayCanvas, if availableif assigned(fDisplayCanvas) thenbeginIF not fImageUnpacked thenUnpackFrame(fImagePtrSize[fImagePtrIndex], fImagePtr[fImagePtrIndex]);IF fDisplayCanvas.LockCount < 1 thenbeginfDisplayCanvas.lock;tryIF fGray8Bitthen fDisplayCanvas.Draw(0, 0, fBitmapGray)else fDisplayCanvas.Draw(0, 0, fBitmap);finallyfDisplayCanvas.unlock;end;end;end;
END;procedure TVideoImage.UnpackFrame(Size: integer; pData: pointer);
var{f       : file;}Unknown : boolean;FourCCSt: string[4];
beginIF pData = nilthen exit;Unknown := false;tryCase fFourCC OF0           :  BEGINIF (Size = fWidth*fHeight*3)then beginif fGray8Bitthen RGB_to_Gray8Bit(pData) // Okay, this is when Grayscale is much slower than color  :(else move(pData^, FBitmap.scanline[fHeight-1]^, Size);endelse Unknown := true;END;FourCC_YUY2,FourCC_YUYV,FourCC_YUNV :  BEGINUnknown := (Size <> fWidth*fHeight*2);IF Unknown thenbegin// Special treatment in case too much data is sent.// e.g. Microsoft LifeCam Cinema delivers 1280*1080*2 Bytes//      when 1280*720 was selected. The extra Bytes do not//      contain video data. One third of the data (921600 Bytes)//      is wasted by the driver!if (Size > fWidth * fHeight * 2) thenUnknown := (Size div (2 * fWidth)) mod 4 <> 0;  // Width a multiple of 4? Maybe OK.end;IF not(Unknown) thenbeginIF fGray8Bitthen YUY2_to_Gray8Bit(pData)else YUY2_to_RGB(pData);end;END;FourCC_MJPG :  BEGINtryMemStream.Clear;MemStream.SetSize(Size);MemStream.Position := 0;MemStream.WriteBuffer(pData^, Size);MemStream.Position := 0;JPG.Grayscale := fGray8Bit;JPG.LoadFromStream(MemStream);if fGray8Bitthen FBitmapGray.Canvas.Draw(0, 0, JPG)else FBitmap.Canvas.Draw(0, 0, JPG);exceptUnknown := true;end;END;FourCC_I420,FourCC_YV12,FourCC_IYUV : BEGINUnknown := (Size <> (fWidth*fHeight*3) div 2);IF not Unknown thenIF fGray8Bitthen I420_to_Gray8Bit(pData)else I420_to_RGB(pData);END;else          BEGIN{assignfile(f, 'Unknown_Frame.dat');rewrite(f, 1);Blockwrite(f, pData^, Size);closefile(f);}Unknown := true;END;end; {case}IF Unknown thenbeginIF fFourCC = 0then FourCCSt := 'RGB'else beginFourCCSt := '    ';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;exceptend;
end;procedure TVideoImage.GetBitmap(BMP: TBitmap);
beginIF not fImageUnpacked thenUnpackFrame(fImagePtrSize[fImagePtrIndex], fImagePtr[fImagePtrIndex]);if fGray8Bitthen BMP.Assign(fBitmapGray)else 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);
beginfDisplayCanvas := Canvas;
end;procedure TVideoImage.ShowProperty;
beginVideoSample.ShowPropertyDialog;
end;procedure TVideoImage.ShowProperty_Stream;
varhr     : HResult;W, H   : integer;FourCC : cardinal;
beginVideoSample.ShowPropertyDialog_CaptureStream;hr := VideoSample.GetStreamInfo(W, H, FourCC);IF Failed(HR)then beginVideoStop;endelse BEGINfWidth := W;fHeight := H;fFourCC := FourCC;FBitmap.PixelFormat := pf24bit;FBitmap.Width := W;FBitmap.Height := H;PrepareGrayBMP(FBitmapGray, W, H);VideoSample.SetCallBack(CallBack);END;
end;FUNCTION  TVideoImage.ShowVfWCaptureDlg: HResult;
beginResult := 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);
BEGINVideoSample.GetListOfVideoSizes(VidSize);
END;PROCEDURE TVideoImage.SetResolutionByIndex(Index: integer);
VARhr     : HResult;W, H   : integer;FourCC : cardinal;
BEGINVideoSample.SetVideoSizeByListIndex(Index);hr := VideoSample.GetStreamInfo(W, H, FourCC);IF Succeeded(HR)then beginfWidth := W;fHeight := H;fFourCC := FourCC;FBitmap.PixelFormat := pf24bit;FBitmap.Width := W;FBitmap.Height := H;PrepareGrayBMP(FBitmapGray, W, H);END;
END;end.

unit VSample;(******************************************************************************VSample.pasClass TVideoSampleAboutThe TVideoSample class provides access to WebCams and similar Video-capturedevices via DirectShow.It is based mainly on C++ examples from the Microsoft DirectX 9.0 SDK Update(Summer 2003): PlayCap and PlayCapMoniker. Comments found in those samplesare copied into this Delphi code.Depends on the DirectX Header conversion files which could be found here:- http://www.progdigy.com- http://www.clootie.ru/delphiHistoryVersion 1.222012-07-08 (Fixed some memory leaks. List of supported video sizes/compressions corrected)Version 1.2106.05.2012  (ansichar instead of char)Version 1.223.08.2009Version 1.107.09.2008Version 1.0330.08.2008Version 1.0226.07.2008Version 1.0103.05.2008Version 1.016.01.2006Contact:michael@grizzlymotion.comCopyrightPortions created by Microsoft are Copyright (C) Microsoft Corporation.Original file names: PlayCap.cpp, PlayCapMoniker.cpp.For copyrights of the DirectX Header ports see the original source files.Other code (unless stated otherwise, see comments): Copyright (C) M. BraunLicence:The lion share of this project lies within the ports of the DirectX headerfiles (which are under the Mozilla Public License Version 1.1), and theoriginal SDK sample files from Microsoft (END-USER LICENSE AGREEMENT FORMICROSOFT SOFTWARE DirectX 9.0 Software Development Kit Update (Summer 2003))My own contribution compared to that work is very small (although it cost melots of time), but still is "significant enough" to fulfill Microsofts licenceagreement ;)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)******************************************************************************)interfaceUSES Windows, Messages, SysUtils, Classes, ActiveX, Forms,{$ifdef DXErr} DXErr9, {$endif}DirectShow9;{ $ define REGISTER_FILTERGRAPH}CONSTWM_GRAPHNOTIFY = WM_APP+1;WM_NewFrame    = WM_User+2;   // Used to inform application that a new video// frame has arrived. Necessary only, if// application hasn't defined a callback// routine via TVideoSample.SetCallBack(...).
CONST  { Copied from OLE2.pas }{$EXTERNALSYM IID_IUnknown}IID_IUnknown: TGUID = (D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));TYPETPLAYSTATE      = (PS_Stopped,{PS_Init,}PS_Paused,PS_Running);// ---= Pseudo-Interface for Frame Grabber Callback Routines =-------------
// c.f. Delphi Help text "Delegating to a class-type property"
//
// ISampleGrabber.SetCallback verlangt als ersten Parameter ein "ISampleGrabberCB"
// Um f ein solches Interface Routinen zu deklarieren ist scheinbar das
// folgende, sonderbare Konstrukt n飆ig.
//
// ISampleGrabber.SetCallback needs an "ISampleGrabberCB" as first parameter.
// This is my attempt to build such a thing with Delphi.

TYPETVideoSampleCallBack= procedure(pb : pbytearray; var Size: integer) of object;TSampleGrabberCBInt = interface(ISampleGrabberCB)function  SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall;function  BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: longint): HResult; stdcall;end;TSampleGrabberCBImpl= classCallBack    : TVideoSampleCallBack;function  SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall;function  BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: longint): HResult; stdcall;end;TSampleGrabberCB =    class(TInterfacedObject, TSampleGrabberCBInt)FSampleGrabberCB: TSampleGrabberCBImpl;CallBack    : TVideoSampleCallBack;property SampleGrabberCB: TSampleGrabberCBImpl read FSampleGrabberCB implements TSampleGrabberCBInt;end;TFormatInfo   = RECORDWidth,Height : integer;SSize  : cardinal;OIndex : integer;mt     : TAMMediaType;FourCC : ARRAY[0..3] OF ansichar;  // ansichar, because in Delphi 2009 char is something different ;)
                  END;TVideoSample  = class(TObject)privateghApp             : HWND;pIVideoWindow     : IVideoWindow;pIMediaControl    : IMediaControl;pIMediaEventEx    : IMediaEventEx;pIGraphBuilder    : IGraphBuilder;pICapGraphBuild2  : ICaptureGraphBuilder2;g_psCurrent       : TPLAYSTATE;pIAMStreamConfig  : IAMStreamConfig;piBFSampleGrabber : IBaseFilter;pIAMVideoProcAmp  : IAMVideoProcAmp;pIBFNullRenderer  : IBaseFilter;pIKsPropertySet   : IKsPropertySet;pISampleGrabber   : ISampleGrabber;pIBFVideoSource   : IBaseFilter;{$ifdef REGISTER_FILTERGRAPH}g_dwGraphRegister :DWORD;{$endif}SGrabberCB  : TSampleGrabberCB;_SGrabberCB : TSampleGrabberCBInt;fVisible    : boolean;CallBack    : TVideoSampleCallBack;FormatArr   : ARRAY OF TFormatInfo;FUNCTION    GetInterfaces(ForceRGB: boolean; WhichMethodToCallback: integer): HRESULT;FUNCTION    SetupVideoWindow(): HRESULT;FUNCTION    ConnectToCaptureDevice(DeviceName: string; VAR DeviceSelected: string; VAR ppIBFVideoSource: IBaseFilter): HRESULT;FUNCTION    RestartVideoEx(Visible: boolean):HRESULT;FUNCTION    ShowPropertyDialogEx(const IBF: IUnknown; FilterName:  PWideChar): HResult;FUNCTION    LoadListOfResolution: HResult;procedure   DeleteBelow(const IBF: IBaseFilter);procedure   CloseInterfaces;public{$ifdef DXErr}DXErrString: string;  // for debugging{$endif}constructor Create(VideoCanvasHandle: THandle; ForceRGB: boolean; WhichMethodToCallback: integer; VAR HR: HResult);destructor  Destroy; override;property    PlayState: TPLAYSTATE read g_psCurrent;procedure   ResizeVideoWindow();FUNCTION    RestartVideo:HRESULT;FUNCTION    StartVideo(CaptureDeviceName: string; Visible: boolean; VAR DeviceSelected: string):HRESULT;FUNCTION    PauseVideo: HResult;  // Pause running videoFUNCTION    ResumeVideo: HResult; // Re-start paused video
                      FUNCTION    StopVideo: HResult;function    GetImageBuffer(VAR pb : pbytearray; var Size: integer): HResult;FUNCTION    SetPreviewState(nShow: boolean): HRESULT;FUNCTION    ShowPropertyDialog: HResult;FUNCTION    ShowPropertyDialog_CaptureStream: HResult;FUNCTION    GetVideoPropAmpEx(    Prop           : TVideoProcAmpProperty;VAR pMin, pMax,pSteppingDelta,pDefault       : longint;VAR pCapsFlags     : TVideoProcAmpFlags;VAR pActual        : longint): HResult;FUNCTION    SetVideoPropAmpEx(    Prop           : TVideoProcAmpProperty;pCapsFlags     : TVideoProcAmpFlags;pActual        : longint): HResult;PROCEDURE   GetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; VAR AcPerCent: integer);PROCEDURE   SetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; AcPerCent: integer);PROCEDURE   GetVideoSize(VAR Width, height: integer);FUNCTION    ShowVfWCaptureDlg: HResult;FUNCTION    GetStreamInfo(VAR Width, Height: integer; VAR FourCC: dword): HResult;FUNCTION    GetExProp(    guidPropSet   : TGuiD;dwPropID      : TAMPropertyPin;pInstanceData : pointer;cbInstanceData: DWORD;out pPropData;cbPropData    : DWORD;out pcbReturned   : DWORD): HResult;FUNCTION    SetExProp(   guidPropSet : TGuiD;dwPropID : TAMPropertyPin;pInstanceData  : pointer;cbInstanceData : DWORD;pPropData : pointer;cbPropData : DWORD): HResult;FUNCTION    GetCaptureIAMStreamConfig(VAR pSC: IAMStreamConfig): HResult;PROCEDURE   DeleteCaptureGraph;PROCEDURE   SetCallBack(CB: TVideoSampleCallBack);FUNCTION    GetPlayState: TPlayState;  // Deprecated
                      PROCEDURE   GetListOfVideoSizes(VidSize: TStringList);FUNCTION    SetVideoSizeByListIndex(ListIndex: integer): HResult;{$ifdef REGISTER_FILTERGRAPH}FUNCTION AddGraphToRot(pUnkGraph: IUnknown; VAR pdwRegister: DWORD):HRESULT;procedure RemoveGraphFromRot(pdwRegister: dword);{$endif}END;FUNCTION TGUIDEqual(const TG1, TG2 : TGUID): boolean;FUNCTION GetCaptureDeviceList(VAR SL: TStringList): HResult;implementationFUNCTION TGUIDEqual(const TG1, TG2 : TGUID): boolean;
BEGINResult := CompareMem(@TG1, @TG2, SizeOf(TGUID));
END; {TGUIDEqual}{ Get a list of all capture devices installed }
FUNCTION GetCaptureDeviceList(VAR SL: TStringList): HResult;
VARpDevEnum     : ICreateDevEnum;pClassEnum   : IEnumMoniker;st           : string;// Okay, in the original C code from the microsoft samples this// is not a subroutine.// I decided to use it as a subroutine, because Delphi won't let// me free pMoniker or pPropertyBag myself. ( ":= nil" )// Hopefully ending the subroutine will clean up all instances of// these interfaces automatically...FUNCTION GetNextDeviceName(VAR Name: string): boolean;VARpMoniker     : IMoniker;pPropertyBag : IPropertyBag;v            : OLEvariant;cFetched     : ulong;BEGINResult := false;Name   := '';pMoniker := nil;IF (S_OK = (pClassEnum.Next (1, pMoniker, @cFetched))) THENBEGINpPropertyBag := nil;if S_OK = pMoniker.BindToStorage(nil, nil, IPropertyBag, pPropertyBag) thenbeginif S_OK = pPropertyBag.Read('FriendlyName', v, nil) thenbeginName := v;Result := true;end;end;END;END; {GetNextDeviceName}beginResult := S_FALSE;if not(assigned(SL)) thenSL := TStringlist.Create;trySL.Clear;exceptexit;end;// Create the system device enumeratorResult := CoCreateInstance (CLSID_SystemDeviceEnum,nil,CLSCTX_INPROC_SERVER,IID_ICreateDevEnum,pDevEnum);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenbegin// Couldn't create system enumerator!
      exit;end;// Create an enumerator for the video capture devicespClassEnum := nil;Result := pDevEnum.CreateClassEnumerator (CLSID_VideoInputDeviceCategory, pClassEnum, 0);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenbegin// Couldn't create class enumerator!
      exit;end;// If there are no enumerators for the requested type, then// CreateClassEnumerator will succeed, but pClassEnum will be nil.if (pClassEnum = nil) thenbegin// No video capture device was detected.
       exit;end;WHILE GetNextDeviceName(st) DOSL.Add(st);
end; {GetCaptureDeviceList}// ---= Sample Grabber callback routines =------------------------------------// In routine TVideoSample.GetInterfaces(..) the callback routine is defined
// with pISampleGrabber.SetCallback(..,..). If the second parameter in that
// call is 1, then the routine below is called during a callback.
// Otherwise, if the parameter is 0, callback routine BufferCB would be called.
function TSampleGrabberCBImpl.SampleCB(SampleTime: Double; pSample: IMediaSample): HResult; stdcall;
varBufferLen: integer;ppBuffer : pbyte;
beginBufferLen := pSample.GetSize;if BufferLen > 0 thenbeginpSample.GetPointer(ppBuffer); {*}if @CallBack = nilthen SendMessage(Application.Mainform.handle, WM_NewFrame, BufferLen, integer(ppBuffer))else Callback(pbytearray(ppBuffer), BufferLen);end;Result := 0;
end;{*}
// Nebenbei bemerkt: Beim Debuggen fiel mir auf, da?die von mir verwendete
// WebCam scheinbar einen Triple-Buffer f die Bilddaten verwendet. Die oben
// von pSample.GetPointer(ppBuffer) zurkgelieferte Adresse wiederholt sich
// in einem 3-er Zyklus. Wenn das ein Feature von DirectShow ist und nicht
// von der Kamera-Steuersoftware, dann k霵nte man selbst auf Double- oder
// Triplebuffering verzichten. // In routine TVideoSample.GetInterfaces(..) the callback routine is defined
// with pISampleGrabber.SetCallback(..,..). If the second parameter in that
// call is 0, then the routine below is called during a callback.
// Otherwise, if the parameter is 1, callback routine SampleCB would be called.
function TSampleGrabberCBImpl.BufferCB(SampleTime: Double; pBuffer: PByte; BufferLen: longint): HResult; stdcall;
beginif BufferLen > 0 thenbeginif @CallBack = nilthen SendMessage(Application.Mainform.handle, WM_NewFrame, BufferLen, integer(pBuffer))else Callback(pbytearray(pBuffer), BufferLen);end;Result := 0;
end;// ---= End of Sample Grabber callback routines =---------------------------constructor TVideoSample.Create(VideoCanvasHandle: THandle; ForceRGB: boolean; WhichMethodToCallback: integer; VAR HR: HResult);
beginghApp             := 0;pIVideoWindow     := nil;pIMediaControl    := nil;pIMediaEventEx    := nil;pIGraphBuilder    := nil;pICapGraphBuild2  := nil;g_pSCurrent       := PS_Stopped;pIAMStreamConfig  := nil;piBFSampleGrabber := nil;pIAMVideoProcAmp  := nil;pIKsPropertySet   := nil;{$ifdef REGISTER_FILTERGRAPH}g_dwGraphRegister:=0;{$endif}pISampleGrabber   := nil;pIBFVideoSource   := nil;SGrabberCB        := nil;_SGrabberCB       := nil;pIBFNullRenderer  := nil;CallBack          := nil;inherited create;ghApp             := VideoCanvasHandle;HR                := GetInterfaces(ForceRGB, WhichMethodToCallback);
end;FUNCTION TVideoSample.GetInterfaces(ForceRGB: boolean; WhichMethodToCallback: integer): HRESULT;
VARMT: _AMMediaType;
BEGIN//--- Create the filter graphResult := CoCreateInstance(CLSID_FilterGraph,nil,CLSCTX_INPROC,IID_IGraphBuilder,pIGraphBuilder);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;//--- Create Sample grabberResult := CoCreateInstance(CLSID_SampleGrabber,nil,CLSCTX_INPROC_SERVER,IBaseFilter,piBFSampleGrabber);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;Result := CoCreateInstance(CLSID_NullRenderer, nil, CLSCTX_INPROC_SERVER,IID_IBaseFilter, pIBFNullRenderer);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;Result := piBFSampleGrabber.QueryInterface(IID_ISampleGrabber, pISampleGrabber);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;pISampleGrabber.SetBufferSamples(false);  // No buffering required in this demo//--- Force 24bit color depth. (RGB24 erzwingen)IF ForceRGB thenbeginFillChar(MT, sizeOf(MT), #0);MT.majortype := MediaType_Video;MT.subtype := MediaSubType_RGB24;Result := pISampleGrabber.SetMediaType(MT);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;end;//--- Prepare Sample-Grabber Callback Object----if not assigned(SGrabberCB) thenbeginSGrabberCB := TSampleGrabberCB.Create;TSampleGrabberCB(SGrabberCB).FSampleGrabberCB := TSampleGrabberCBImpl.Create;_SGrabberCB := TSampleGrabberCB(SGrabberCB);// Should this be _SGrabberCB := SGrabberCB as TSampleGrabberCB ?????!!!!!// Compare discussion on// http://delphi.newswhat.com/geoxml/forumgetthread?groupname=borland.public.delphi.oodesign&messageid=44f84705@newsgroups.borland.com&displaymode=all// However, link has been lost in the web  :(end;pISampleGrabber.SetCallback(ISampleGrabberCB(_SGrabberCB), WhichMethodToCallback);// WhichMethodToCallback=0: SampleGrabber calls SampleCB with the original media sample// WhichMethodToCallback=1: SampleGrabber calls BufferCB with a copy of the media sample//--- Create the capture graph builderResult := CoCreateInstance(CLSID_CaptureGraphBuilder2,nil,CLSCTX_INPROC,IID_ICaptureGraphBuilder2,pICapGraphBuild2);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;// Obtain interfaces for media control and Video WindowResult := pIGraphBuilder.QueryInterface(IID_IMediaControl, pIMediaControl);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;Result := pIGraphBuilder.QueryInterface(IID_IVideoWindow, pIVideoWindow);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;Result := pIGraphBuilder.QueryInterface(IID_IMediaEvent, pIMediaEventEx);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenexit;//--- Set the window handle used to process graph eventsResult := pIMediaEventEx.SetNotifyWindow(OAHWND(ghApp), WM_GRAPHNOTIFY, 0);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
end;FUNCTION TVideoSample.ConnectToCaptureDevice(DeviceName: string; VAR DeviceSelected: string; VAR ppIBFVideoSource: IBaseFilter): HRESULT;
VARpDevEnum   : ICreateDevEnum;pClassEnum : IEnumMoniker;Index      : integer;Found      : boolean;// see also: http://msdn.microsoft.com/en-us/library/ms787619.aspxFUNCTION CheckNextDeviceName(Name: string; VAR Found: boolean): HResult;VARpMoniker     : IMoniker;pPropertyBag : IPropertyBag;v            : OLEvariant;cFetched     : ulong;MonName      : string;BEGINFound  := false;pMoniker := nil;// Note that if the Next() call succeeds but there are no monikers,// it will return S_FALSE (which is not a failure).  Therefore, we// check that the return code is S_OK instead of using SUCCEEDED() macro.Result := pClassEnum.Next(1, pMoniker, @cFetched);IF (S_OK = Result) THENBEGINInc(Index);pPropertyBag := nil;Result := pMoniker.BindToStorage(nil, nil, IPropertyBag, pPropertyBag);if S_OK = Result thenbeginResult := pPropertyBag.Read('FriendlyName', v, nil);   // BTW: Other useful parameter: 'DevicePath'if S_OK = Result thenbeginMonName := v;if (Uppercase(Trim(MonName)) = UpperCase(Trim(Name))) or((Length(Name)=2) and (Name[1]='#') and (ord(Name[2])-48=Index)) thenbeginDeviceSelected := Trim(MonName);Result := pMoniker.BindToObject(nil, nil, IID_IBaseFilter, ppIBFVideoSource);Found := Result = S_OK;end;end;end;END;END; {CheckNextDeviceName}BEGINDeviceSelected := '';Index := 0;DeviceName := Trim(DeviceName);IF DeviceName = '' thenDeviceName := '#1'; // Default: First device (Erstes Ger酹)if @ppIBFVideoSource = nil thenbeginresult := E_POINTER;exit;end;// Create the system device enumeratorResult := CoCreateInstance(CLSID_SystemDeviceEnum,nil,CLSCTX_INPROC,IID_ICreateDevEnum,pDevEnum);if (FAILED(Result)) thenbegin// Couldn't create system enumerator!
      exit;end;// Create an enumerator for the video capture devicespClassEnum := nil;Result := pDevEnum.CreateClassEnumerator (CLSID_VideoInputDeviceCategory, pClassEnum, 0);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenbegin// Couldn't create class enumerator!
      exit;end;// If there are no enumerators for the requested type, then// CreateClassEnumerator will succeed, but pClassEnum will be nil.if (pClassEnum = nil) thenbegin// No video capture device was detected.result := E_FAIL;exit;end;Found := false;REPEATtryResult := CheckNextDeviceName(DeviceName, Found)exceptIF Result = 0 thenresult := E_FAIL;end;UNTIL Found or (Result <> S_OK);
end; {ConnectToCaptureDevice}procedure TVideoSample.ResizeVideoWindow();
varrc : TRect;
begin// Resize the video preview window to match owner window sizeif (pIVideoWindow) <> nil thenbegin// Make the preview video fill our window
      GetClientRect(ghApp, rc);pIVideoWindow.SetWindowPosition(0, 0, rc.right, rc.bottom);end;
end; {ResizeVideoWindow}FUNCTION TVideoSample.SetupVideoWindow(): HRESULT;
BEGIN// Set the video window to be a child of the main windowResult := pIVideoWindow.put_Owner(OAHWND(ghApp));{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenbeginexit;end;// Set video window styleResult := pIVideoWindow.put_WindowStyle(WS_CHILD or WS_CLIPCHILDREN);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenbeginexit;end;// Use helper function to position video window in client rect// of main application window
  ResizeVideoWindow();// Make the video window visible, now that it is properly positionedResult := pIVideoWindow.put_Visible(TRUE);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if (FAILED(Result)) thenbeginexit;end;end; {SetupVideoWindow}FUNCTION TVideoSample.RestartVideoEx(Visible: boolean):HRESULT;
VARpCut, pTyp : pGuiD;{pAMVidControl: IAMVideoControl;pPin         : IPin;}
BEGINif (pIAMVideoProcAmp = nil) thenif not(S_OK = pIBFVideoSource.QueryInterface(IID_IAMVideoProcAmp, pIAMVideoProcAmp)) thenpIAMVideoProcAmp := nil;if (pIKsPropertySet = nil) thenif not(S_OK = pIBFVideoSource.QueryInterface(IID_IKsPropertySet, pIKsPropertySet)) thenpIKsPropertySet := nil;// Add Capture filter to our graph.Result := pIGraphBuilder.AddFilter(pIBFVideoSource, Widestring('Video Capture'));if (FAILED(Result)) thenbegin// Couldn''t add the capture filter to the graph!
        exit;end;Result := pIGraphBuilder.AddFilter(piBFSampleGrabber, Widestring('Sample Grabber'));if (FAILED(Result)) thenEXIT;if not(Visible) thenbeginResult := pIGraphBuilder.AddFilter(pIBFNullRenderer, WideString('Null Renderer'));if (FAILED(Result)) thenEXIT;end;// Render the preview pin on the video capture filter// Use this instead of pIGraphBuilder->RenderFile
    New(pCut);New(pTyp);//pCut^ := PIN_CATEGORY_PREVIEW;pCut^ := PIN_CATEGORY_CAPTURE;pTyp^ := MEDIATYPE_Video;tryif Visiblethen Result := pICapGraphBuild2.RenderStream (pCut, pTyp,//Addr(PIN_CATEGORY_PREVIEW), Addr(MEDIATYPE_Video),pIBFVideoSource, piBFSampleGrabber, nil)else Result := pICapGraphBuild2.RenderStream (pCut, pTyp,//Addr(PIN_CATEGORY_PREVIEW), Addr(MEDIATYPE_Video),
                                    pIBFVideoSource, piBFSampleGrabber, pIBFNullRenderer);exceptResult := -1;end;if (FAILED(Result)) thenbegin// Couldn''t render the video capture stream.// The capture device may already be in use by another application.
        Dispose(pTyp);Dispose(pCut);exit;end;// Set video window style and positionif Visible thenbeginResult := SetupVideoWindow();if (FAILED(Result)) thenbegin// Couldn't initialize video window!
            Dispose(pTyp);Dispose(pCut);exit;end;end;{$ifdef REGISTER_FILTERGRAPH}// Add our graph to the running object table, which will allow// the GraphEdit application to "spy" on our graphtryhr := AddGraphToRot(IUnknown(pIGraphBuilder), g_dwGraphRegister);except// Failed to register filter graph with ROT!end;if (FAILED(Result)) thenbegin// Failed to register filter graph with ROT!g_dwGraphRegister := 0;end;
{$endif}//  if Visible thenbegin// Start previewing video dataResult := pIMediaControl.Run();if (FAILED(Result)) thenbegin// Couldn't run the graph!end;end;// Remember current stateg_psCurrent := PS_Running;(*// !!!!!!!!!// Prepare getting images in higher resolution than video stream// See DirectX9 Help "Capturing an Image From a Still Image Pin"// Not working yet.....pAMVidControl := nil;Result := pIBFVideoSource.QueryInterface(IID_IAMVideoControl, pAMVidControl);IF succeeded(Result) thenbeginpTyp := 0;pPin := nil;Result := pICapGraphBuild2.FindPin(pIBFVideoSource, PINDIR_OUTPUT, PIN_CATEGORY_STILL, pTyp^, false, 0, pPin);if (SUCCEEDED(Result)) thenResult := pAMVidControl.SetMode(pPin, VideoControlFlag_Trigger);end;*)Dispose(pTyp);Dispose(pCut);
end; {RestartVideoEx}FUNCTION TVideoSample.RestartVideo: HRESULT;
BEGINResult := RestartVideoEx(FVisible);
END; {RestartVideo}FUNCTION TVideoSample.StartVideo(CaptureDeviceName: string; Visible: boolean; VAR DeviceSelected: string):HRESULT;
BEGINpIBFVideoSource := nil;FVisible   := Visible;// Attach the filter graph to the capture graphResult := pICapGraphBuild2.SetFiltergraph(pIGraphBuilder);if (FAILED(Result)) thenbegin// Failed to set capture filter graph!
      exit;end;// Use the system device enumerator and class enumerator to find// a video capture/preview device, such as a desktop USB video camera.Result := ConnectToCaptureDevice(CaptureDeviceName, DeviceSelected, pIBFVideoSource);if (FAILED(Result)) thenbeginexit;end;LoadListOfResolution;Result := RestartVideo;
end;FUNCTION TVideoSample.PauseVideo: HResult;
BEGINIF g_psCurrent = PS_Pausedthen beginResult := S_OK;EXIT;end;IF g_psCurrent = PS_Running thenbeginResult := pIMediaControl.Pause;if Succeeded(Result) theng_psCurrent := PS_Paused;endelse Result := S_FALSE;
END;FUNCTION TVideoSample.ResumeVideo: HResult;
BEGINIF g_psCurrent = PS_Running thenbeginResult := S_OK;EXIT;end;IF g_psCurrent = PS_Paused thenbeginResult := pIMediaControl.Run;if Succeeded(Result) theng_psCurrent := PS_Running;endelse Result := S_FALSE;
END;FUNCTION TVideoSample.StopVideo: HResult;
BEGIN// Stop previewing video dataResult := pIMediaControl.StopWhenReady();g_psCurrent := PS_Stopped;SetLength(FormatArr, 0);
END;// Delete filter and pins bottom-up...
PROCEDURE TVideoSample.DeleteBelow(const IBF: IBaseFilter);
VARhr         : HResult;pins       : IEnumPins;pIPinFrom,pIPinTo    : IPin;fetched    : ulong;pInfo      : _PinInfo;
BEGINpIPinFrom := nil;pIPinTo   := nil;hr := IBF.EnumPins(pins);WHILE (hr = NoError) DOBEGINhr := pins.Next(1, pIPinFrom, @fetched);if (hr = S_OK) and (pIPinFrom <> nil) thenBEGINhr := pIPinFrom.ConnectedTo(pIPinTo);if (hr = S_OK) and (pIPinTo <> nil) thenBEGINhr := pIPinTo.QueryPinInfo(pInfo);if (hr = NoError) thenBEGINif pinfo.dir = PINDIR_INPUT thenBEGINDeleteBelow(pInfo.pFilter);pIGraphBuilder.Disconnect(pIPinTo);pIGraphBuilder.Disconnect(pIPinFrom);pIGraphBuilder.RemoveFilter(pInfo.pFilter);ENd;END;END;END;END;
END; {DeleteBelow}PROCEDURE TVideoSample.DeleteCaptureGraph;
BEGINpIBFVideoSource.Stop;DeleteBelow(pIBFVideoSource);
END;procedure TVideoSample.CloseInterfaces;
beginif (pISampleGrabber <> nil) thenpISampleGrabber.SetCallback(nil, 1);// Stop previewing dataif (pIMediaControl <> nil) thenpIMediaControl.StopWhenReady();g_psCurrent := PS_Stopped;// Stop receiving eventsif (pIMediaEventEx <> nil) thenpIMediaEventEx.SetNotifyWindow(OAHWND(nil), WM_GRAPHNOTIFY, 0);// Relinquish ownership (IMPORTANT!) of the video window.// Failing to call put_Owner can lead to assert failures within// the video renderer, as it still assumes that it has a valid// parent window.if (pIVideoWindow<>nil) thenbeginpIVideoWindow.put_Visible(FALSE);pIVideoWindow.put_Owner(OAHWND(nil));end;{$ifdef REGISTER_FILTERGRAPH}// Remove filter graph from the running object tableif (g_dwGraphRegister<>nil) thenRemoveGraphFromRot(g_dwGraphRegister);{$endif}
end;function TVideoSample.GetImageBuffer(VAR pb : pbytearray; var Size: integer): HResult;
VARNewSize : integer;
beginResult := pISampleGrabber.GetCurrentBuffer(NewSize, nil);if (Result <> S_OK) thenEXIT;if (pb <> nil) thenbeginif Size <> NewSize thenbegintryFreeMem(pb, Size);exceptend;pb := nil;Size := 0;end;end;Size := NewSize;IF Result = S_OK THENBEGINif pb = nil thenGetMem(pb, NewSize);Result := pISampleGrabber.GetCurrentBuffer(NewSize, pb);END;
end;FUNCTION TVideoSample.SetPreviewState(nShow: boolean): HRESULT;
BEGINResult := S_OK;// If the media control interface isn't ready, don't call itif (pIMediaControl = nil) thenexit;if (nShow) thenbeginif (g_psCurrent <> PS_Running) thenbegin// Start previewing video dataResult := pIMediaControl.Run();g_psCurrent := PS_Running;end;endelse begin// Stop previewing video data// Result := pIMediaControl.StopWhenReady(); // Program may get stucked here!Result := pIMediaControl.Stop;g_psCurrent := PS_Stopped;end;
end;FUNCTION TVideoSample.ShowPropertyDialogEx(const IBF: IUnknown; FilterName: PWideChar): HResult;
VARpProp      : ISpecifyPropertyPages;c          : tagCAUUID;
beginpProp  := nil;Result := IBF.QueryInterface(ISpecifyPropertyPages, pProp);if Result = S_OK thenbeginResult := pProp.GetPages(c);if (Result = S_OK) and (c.cElems > 0) thenbeginResult := OleCreatePropertyFrame(ghApp, 0, 0, FilterName, 1, @IBF, c.cElems, c.pElems, 0, 0, nil);CoTaskMemFree(c.pElems);end;end;
end;FUNCTION TVideoSample.ShowPropertyDialog: HResult;
VARFilterInfo : FILTER_INFO;
beginResult := pIBFVideoSource.QueryFilterInfo(FilterInfo);if not(Failed(Result)) thenResult := ShowPropertyDialogEx(pIBFVideoSource, FilterInfo.achName);
end;FUNCTION TVideoSample.GetCaptureIAMStreamConfig(VAR pSC: IAMStreamConfig): HResult;
BEGINpSC := nil;Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_capture,@MEDIATYPE_Video,pIBFVideoSource,IID_IAMStreamConfig, pSC);END;FUNCTION TVideoSample.ShowPropertyDialog_CaptureStream: HResult;
VARpSC       : IAMStreamConfig;
BEGINpIMediaControl.Stop;Result := GetCaptureIAMStreamConfig(pSC);if Result = S_OK thenResult := ShowPropertyDialogEx(pSC, '');{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}pIMediaControl.Run;
END;(*
PROCEDURE DumpMediaType(const mt: TAMMediaType; VAR Dump: TStringList);
beginDump.Add('================');Dump.Add('MajorType=' + GuidToString(mt.majortype));Dump.Add('SubType=' +   GuidToString(mt.subtype));Dump.Add('FixedSizeSamples=' + BoolToStr(mt.bFixedSizeSamples));Dump.Add('TemporalCompression=' + BoolToStr(mt.bTemporalCompression));Dump.Add('lSampleSize=' + IntToStr(mt.lSampleSize));Dump.Add('FormatType='  + GuidToString(mt.formattype));//Dump.Add('pUnk='  +   GuidToString(mt.pUnk));Dump.Add('cbFormat=' + IntToHex(mt.cbFormat, 8));Dump.Add('pbFormat=' + IntToHex(integer(mt.pbFormat), 4));
end;
*)// Fills "FormatArr" with list of all supported video formats (resolution, compression etc...)
FUNCTION TVideoSample.LoadListOfResolution: HResult;
VARpSC                   : IAMStreamConfig;VideoStreamConfigCaps : TVideoStreamConfigCaps;p                     : ^TVideoStreamConfigCaps;ppmt                  : PAMMediaType;i, j,piCount,piSize                : integer;Swap                  : boolean;FM                    : TFormatInfo;
BEGINSetLength(FormatArr, 0);Result := GetCaptureIAMStreamConfig(pSC);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}IF Result = S_OK thenResult := pSC.GetNumberOfCapabilities(piCount, piSize);j := 0;if Result = S_OK thenbeginFOR i := 0 TO piCount-1 DObeginp := @VideoStreamConfigCaps;Result := pSC.GetStreamCaps(i, ppmt, p^);IF Succeeded(Result) thenIF not(IsEqualGUID(ppmt^.formattype, KSDATAFORMAT_SPECIFIER_VIDEOINFO2)) then // Only first part of info is relevantbeginSetLength(FormatArr, j+1);FormatArr[j].OIndex := i;FormatArr[j].Width  := p^.InputSize.cx;FormatArr[j].Height := p^.InputSize.cy;FormatArr[j].mt     := ppmt^;FormatArr[j].SSize  := ppmt^.lSampleSize;IF TGuIDEqual(MEDIASUBTYPE_RGB24, ppmt^.Subtype)then FormatArr[j].FourCC := 'RGB 'else move(ppmt^.Subtype.D1, FormatArr[j].FourCC, 4);Inc(j);end;end;end;// Simple sort by width and heightIF j > 1 thenbeginREPEATSwap := false;FOR i := 0 TO j-2 DOIF (FormatArr[i].Width > FormatArr[i+1].Width) or(((FormatArr[i].Width = FormatArr[i+1].Width)) and ((FormatArr[i].Height > FormatArr[i+1].Height)))thenbeginSwap := true;FM := FormatArr[i];FormatArr[i] := FormatArr[i+1];FormatArr[i+1] := FM;end;UNTIL not(Swap);end;
END;FUNCTION TVideoSample.SetVideoSizeByListIndex(ListIndex: integer): HResult;
// Sets one of the supported video stream sizes listed in "FormatArr".
// ListIndex is the index to one of the sizes from the stringlist received
// from "GetListOfVideoSizes".
VARpSC                   : IAMStreamConfig;
BEGINIF (ListIndex < 0) or (ListIndex >= Length(FormatArr)) thenbeginResult := S_FALSE;exit;end;pIMediaControl.Stop;Result := GetCaptureIAMStreamConfig(pSC);IF Succeeded(Result) then//Result := pSC.SetFormat(FormatArr[ListIndex].mt);// Sometimes delivers VFW_E_INVALIDMEDIATYPE, even for formats returned by GetStreamCaps
pIMediaControl.Run;
END;FUNCTION TVideoSample.GetStreamInfo(VAR Width, Height: integer; VAR FourCC: dword): HResult;
VARpSC   : IAMStreamConfig;ppmt  : PAMMediaType;pmt   : _AMMediaType;VI    : VideoInfo;VIH   : VideoInfoHeader;
BEGINWidth := 0;Height := 0;//pIMediaControl.Stop; // Crash with FakeWebCam. Thanks to "Zacherl" from Delphi-Praxis http://www.delphipraxis.net/1165063-post16.htmlpIBFVideoSource.Stop;  // nicht zwingend n飆ig
Result := GetCaptureIAMStreamConfig(pSC);{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if Result = S_OK thenbeginResult := pSC.GetFormat(ppmt);pmt := ppmt^;if  TGUIDEqual(ppmt.formattype, FORMAT_VideoInfo) thenbeginFillChar(VI, SizeOf(VI), #0);VIH := VideoInfoHeader(ppmt^.pbFormat^);move(VIH, VI, SizeOf(VIH));Width := VI.bmiHeader.biWidth;Height := Abs(VI.bmiHeader.biHeight);FourCC := VI.bmiHeader.biCompression;end;end;pIBFVideoSource.Run(0);// nicht zwingend n飆ig//pIMediaControl.Run;  // If we don't stop it, we don't need to start it...
END;// See also: http://msdn.microsoft.com/en-us/library/ms784400(VS.85).aspx
FUNCTION TVideoSample.GetVideoPropAmpEx(    Prop                     : TVideoProcAmpProperty;VAR pMin, pMax,pSteppingDelta, pDefault : longint;VAR pCapsFlags               : TVideoProcAmpFlags;VAR pActual                  : longint): HResult;
BEGINResult := S_False;if pIAMVideoProcAmp = nil thenexit;Result := pIAMVideoProcAmp.GetRange(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags);pActual := pDefault;IF Result = S_OK thenResult := pIAMVideoProcAmp.Get(Prop, pActual, pCapsFlags)
END;FUNCTION TVideoSample.SetVideoPropAmpEx(    Prop           : TVideoProcAmpProperty;pCapsFlags     : TVideoProcAmpFlags;pActual        : longint): HResult;
BEGINResult := S_False;if pIAMVideoProcAmp = nil thenexit;Result := pIAMVideoProcAmp.Set_(Prop, pActual, pCapsFlags)
END;PROCEDURE TVideoSample.GetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; VAR AcPerCent: integer);
VARpMin, pMax,pSteppingDelta,pDefault       : longint;pCapsFlags     : TVideoProcAmpFlags;pActual        : longint;
BEGINIF GetVideoPropAmpEx(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags, pActual) = S_OKTHEN BEGINAcPerCent := round(100 * (pActual-pMin)/(pMax-pMin));ENDELSE AcPerCent := -1;
END;PROCEDURE TVideoSample.SetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; AcPerCent: integer);
VARpMin, pMax,pSteppingDelta,pDefault        : longint;pCapsFlags      : TVideoProcAmpFlags;pActual         : longint;d               : double;
BEGINIF GetVideoPropAmpEx(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags, pActual) = S_OKTHEN BEGINIF (AcPercent < 0) or (AcPercent > 100) thenbeginpActual := pDefault;endelse begind := (pMax-pMin)/100*AcPercent;pActual := round(d);pActual := (pActual div pSteppingDelta) * pSteppingDelta;pActual := pActual + pMin;end;pIAMVideoProcAmp.Set_(Prop, pActual, pCapsFlags);END
END;PROCEDURE TVideoSample.GetVideoSize(VAR Width, height: integer);
VARpBV : IBasicVideo;
BEGINWidth := 0;Height := 0;pBV := nil;if pIGraphBuilder.QueryInterface(IID_IBasicVideo, pBV)=S_OK then
//  if pICapGraphBuild2.FindInterface(@PIN_CATEGORY_capture, @MEDIATYPE_Video, pIBFVideoSource, IID_IBasicVideo, pBV) = S_OK then
    pBV.GetVideoSize(Width, height);
END; {GetVideoSize}FUNCTION TVideoSample.ShowVfWCaptureDlg: HResult;
VARpVfw : IAMVfwCaptureDialogs;
BEGINpVfw := nil;pIMediaControl.Stop;Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_CAPTURE,@MEDIATYPE_Video,pIBFVideoSource,IID_IAMVfwCaptureDialogs, pVfW);if not(Succeeded(Result)) then // RetryResult := pICapGraphBuild2.queryinterface(IID_IAMVfwCaptureDialogs, pVfw);if not(Succeeded(Result)) then // RetryResult := pIGraphBuilder.queryinterface(IID_IAMVfwCaptureDialogs, pVfw);if (SUCCEEDED(Result)) THENBEGIN// Check if the device supports this dialog box.if (S_OK = pVfw.HasDialog(VfwCaptureDialog_Source)) then// Show the dialog box.Result := pVfw.ShowDialog(VfwCaptureDialog_Source, ghApp);END;pIMediaControl.Run;
END;FUNCTION TVideoSample.GetExProp(   guidPropSet : TGuiD;dwPropID : TAMPropertyPin;pInstanceData  : pointer;cbInstanceData : DWORD;out pPropData;cbPropData : DWORD;out pcbReturned: DWORD): HResult;
BEGINResult := pIKsPropertySet.Get(guidPropSet, dwPropID, pInstanceData, cbInstanceData, pPropData, cbPropData, pcbReturned);
END;FUNCTION TVideoSample.SetExProp(   guidPropSet : TGuiD;dwPropID : TAMPropertyPin;pInstanceData  : pointer;cbInstanceData : DWORD;pPropData : pointer;cbPropData : DWORD): HResult;
BEGINResult := pIKsPropertySet.Set_(guidPropSet, dwPropID, pInstanceData, cbInstanceData, pPropData, cbPropData);
END;// Does work, if no GDI functions are called within callback!
// See remark on http://msdn.microsoft.com/en-us/library/ms786692(VS.85).aspx
PROCEDURE TVideoSample.SetCallBack(CB: TVideoSampleCallBack);
BEGINCallBack := CB;SGrabberCB.FSampleGrabberCB.CallBack := CB;
END;FUNCTION TVideoSample.GetPlayState: TPlayState;
BEGINResult := g_psCurrent;
END;PROCEDURE TVideoSample.GetListOfVideoSizes(VidSize: TStringList);
VARi : integer;
BEGINtryIF not(assigned(VidSize)) thenVidSize := TStringList.Create;VidSize.Clear;exceptexit;end;IF g_psCurrent < PS_Paused thenexit;FOR i := 0 TO Length(FormatArr)-1 DOVidSize.Add(IntToStr(FormatArr[i].Width)+'*'+IntToStr(FormatArr[i].Height) + '  (' + FormatArr[i].FourCC+')');
END;{$ifdef REGISTER_FILTERGRAPH}FUNCTION TVideoSample.AddGraphToRot(pUnkGraph: IUnknown; VAR pdwRegister: DWORD):HRESULT;
VARpMoniker   : IMoniker;pRot       : IRunningObjectTable;sz         : string;wsz        : ARRAY[0..128] OF wchar;hr         : HResult;dwRegister : integer absolute pdwregister;i : integer;
BEGIN{if (!pUnkGraph || !pdwRegister)return E_POINTER;}if (FAILED(GetRunningObjectTable(0, pROT))) thenbeginresult := E_FAIL;exit;end;{wsprintfW(wsz, 'FilterGraph %08x pid %08x\0', DWORD_PTR(pUnkGraph),GetCurrentProcessId());}sz := 'FilterGraph ' + lowercase(IntToHex(integer((pUnkGraph)), 8))+' pid '+lowercase(IntToHex(GetCurrentProcessID,8))+#0;fillchar(wsz, sizeof(wsz), #0);for i := 1 to length(sz) DOwsz[i-1] := widechar(sz[i]);hr := CreateItemMoniker('!', wsz, pMoniker);if (SUCCEEDED(hr)) thenbegin// Use the ROTFLAGS_REGISTRATIONKEEPSALIVE to ensure a strong reference// to the object.  Using this flag will cause the object to remain// registered until it is explicitly revoked with the Revoke() method.//
        // Not using this flag means that if GraphEdit remotely connects// to this graph and then GraphEdit exits, this object registration// will be deleted, causing future attempts by GraphEdit to fail until// this application is restarted or until the graph is registered again.hr := pROT.Register(ROTFLAGS_REGISTRATIONKEEPSALIVE, pUnkGraph,pMoniker, dwRegister);
//        i := pMoniker._Release;  // <- Delphi wont let me do this myself!end;//    pROT._Release(); // <- Delphi wont let me do this myself!result := hr;
end;// Removes a filter graph from the Running Object Table
procedure TVideoSample.RemoveGraphFromRot(pdwRegister: dword);
VARpROT :  IRunningObjectTable;
beginif (SUCCEEDED(GetRunningObjectTable(0, pROT))) thenbeginpROT.Revoke(pdwRegister);
//      pROT._Release();end;
end;{$endif}(*
FUNCTION TVideoSample.GetStreamInfoTest(VAR Width, Height: integer; VAR FourCC: dword): HResult;
VARpSC   : IAMStreamConfig;ppmt  : PAMMediaType;pmt   : _AMMediaType;VI    : VideoInfo;VIH   : VideoInfoHeader;
BEGINWidth := 0;Height := 0;pIMediaControl.Stop;pIBFVideoSource.Stop;  // nicht zwingend n飆igpSC := nil;Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_capture,@MEDIATYPE_Video,pIBFVideoSource,IID_IAMStreamConfig, pSC);pSC.GetNumberOfCapabilities(piCount, piSize){$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}if Result = S_OK thenbeginpSC.GetFormat(ppmt);pmt := ppmt^;if  TGUIDEqual(ppmt.formattype, FORMAT_VideoInfo) thenbeginFillChar(VI, SizeOf(VI), #0);VIH := VideoInfoHeader(ppmt^.pbFormat^);move(VIH, VI, SizeOf(VIH));Width := VI.bmiHeader.biWidth;Height := Abs(VI.bmiHeader.biHeight);FourCC := VI.bmiHeader.biCompression;end;end;pIBFVideoSource.Run(0);// nicht zwingend n飆ig
  pIMediaControl.Run;
END;
*)destructor TVideoSample.Destroy;
begintrySetPreviewState(false);pIMediaControl.Stop;pIBFVideoSource.Stop;DeleteCaptureGraph;closeInterfaces;if assigned(SGrabberCB) and assigned(TSampleGrabberCB(SGrabberCB).FSampleGrabberCB) thenbeginTSampleGrabberCB(SGrabberCB).FSampleGrabberCB.Free;TSampleGrabberCB(SGrabberCB).FSampleGrabberCB := nil;end;finallytryinherited destroy;exceptend;end;
end;end.

unit uBarcode;interface
uses Winapi.Windows, Vcl.Graphics,System.Types,System.SysUtils,Vcl.ExtCtrls;{生成QRCODE时会用到的几个参数：1、TZintSymbol.symbology 条码类型，本例中使用BARCODE_QRCODE，对应的值为58，更多条码类型参考zint.h头文件中的定义2、TZintSymbol.option_1 容错级别，本例中没有设置。对应的值为1、2、3、4 ，也就是LEVEL_L、LEVEL_M、LEVEL_Q、LEVEL_H3、TZintSymbol.option_2 图像大小，取值范围为1 - 40，数值越大生成的图像越大。3、TZintSymbol.input_mode 输入类型，取值范围0、1、2、3、4，分别表示DATA_MODE、UNICODE_MODE、GS1_MODE、KANJI_MODE、SJIS_MODE；默认值为0，即DATA_MODE。建议处理中文时使用DATA_MODE，并将输入内容编码为UTF8。
}
typeTZintLevel=(LEVEL_L=1,LEVEL_M,LEVEL_Q,LEVEL_H);TZintSymbol = packed recordsymbology: Integer;height: Integer;whitespace_width: Integer;border_width: Integer;output_options: Integer;fgcolour: array[0..9] of AnsiChar;bgcolour: array[0..9] of AnsiChar;outfile: array[0..255] of AnsiChar;scale: Single;option_1: Integer; //容错级别option_2: Integer;option_3: Integer;show_hrt: Integer;input_mode: Integer;eci: Integer;text: array[0..127] of AnsiChar;rows: Integer;width: Integer;primary: array[0..127] of AnsiChar;encoded_data: array[0..199, 0..142] of AnsiChar;row_height: array[0..199] of Integer; // Largest symbol is 189 x 189errtxt: array[0..99] of AnsiChar;bitmap: PAnsiChar;bitmap_width: Integer;bitmap_height: Integer;bitmap_byte_length: Cardinal;dot_size: Single;rendered: Pointer;debug: Integer;end;PZintSymbol = ^TZintSymbol;Type TZint=class(Tobject)privateFSymbol : PZintSymbol;FData : UTF8String;FImage : TImage;FBitmap: TBitmap;FType : Integer; //條碼類型
    FLevel : TZintLevel;function ZBarcodeCreate: PZintSymbol;procedure ZBarcodeDelete;function ZBarcodeEncodeAndOutput(out AErr:string):Integer;procedure ZBarcode_To_Bitmap;publicprocedure ShowBarCode;publicconstructor Create(AData:string; AImage: TImage; ALevel:TZintLevel=LEVEL_L;AType:Integer=58);destructor Destroy;override;
end;// create bitmap 这个函数是使用编码后的条码图像数据生成Bitmap文件，不属于zint，因此不在zint.h头文件中，上面的三个在zint.h头文件中。// procedure ZBarcode_To_Bitmap(symbol: PZintSymbol;var ABitmap: TBitmap);
implementation
const// Tbarcode 7 codesBARCODE_QRCODE        = 58;LibName = 'zint.dll';//struct zint_symbol *ZBarcode_Create(void);function ZBarcode_Create(): PZintSymbol; cdecl; external LibName;//void ZBarcode_Delete(struct zint_symbol *symbol);procedure ZBarcode_Delete(symbol: PZintSymbol); cdecl; external LibName;//int ZBarcode_Encode_and_Buffer(struct zint_symbol *symbol, unsigned char *input, int length, int rotate_angle);function ZBarcode_Encode_and_Buffer(symbol: PZintSymbol; input: PAnsiChar; length, rotate_angle: Integer): Integer; cdecl; external LibName;{ TZint }constructor TZint.Create(AData: string; AImage: TImage;ALevel:TZintLevel;AType:Integer);
beginif not Assigned(AImage) thenraise Exception.Create('not assigned(Bitmap)');FData := UTF8String(AData);FImage := AImage;FSymbol := ZBarcodeCreate;FType := AType; //條碼類型FLevel := ALevel;FSymbol.option_1 := Ord(FLevel);FBitmap := TBitmap.Create;if not Assigned(FSymbol) thenraise Exception.Create('Generate BarCode Failed!');FSymbol.symbology := FType;
end;destructor TZint.Destroy;
beginFBitmap.Free;FBitmap := nil;ZBarcodeDelete;inherited;
end;procedure TZint.ShowBarCode;
varAErrNumber : integer;AErrMsg : string;
beginAErrNumber := ZBarcodeEncodeAndOutput(AErrMsg);FImage.Picture.Bitmap.Width := FImage.Width;FImage.Picture.Bitmap.Height := FImage.Height;FImage.Picture.Bitmap.Canvas.Brush.Color := clWhite;FImage.Picture.Bitmap.Canvas.FillRect(Rect(0, 0, FImage.Width, FImage.Height));if AErrNumber=0 thenbeginZBarcode_To_Bitmap;FImage.Picture.Bitmap.Canvas.StretchDraw(Rect(10, 10, FImage.Width - 10, FImage.Height - 10), FBitmap);endelseraise Exception.Create('编码时发生错误：' + AErrMsg);end;function TZint.ZBarcodeCreate:PZintSymbol;
beginResult := ZBarcode_Create;
end;procedure TZint.ZBarcodeDelete;
beginZBarcode_Delete(FSymbol);
end;function TZint.ZBarcodeEncodeAndOutput(out AErr:string): Integer;
beginResult := ZBarcode_Encode_and_Buffer(FSymbol,PAnsiChar(FData),Length(FData),0);AErr := string(AnsiString(FSymbol.errtxt));
end;procedure TZint.ZBarcode_To_Bitmap;
varSrcRGB: PRGBTriple;Row, RowWidth: Integer;
beginFBitmap.PixelFormat := pf24bit;FBitmap.SetSize(Fsymbol.bitmap_width, Fsymbol.bitmap_height);SrcRGB := Pointer(Fsymbol.bitmap);RowWidth := Fsymbol.bitmap_width * 3;for Row := 0 to Fsymbol.bitmap_height - 1 dobeginCopyMemory(FBitmap.ScanLine[Row], SrcRGB, RowWidth);Inc(SrcRGB, Fsymbol.bitmap_width);end;SetBitmapBits(FBitmap.Handle, Fsymbol.bitmap_width * Fsymbol.bitmap_height * 3, Fsymbol.bitmap);end;end.

unit uScanBarCode;interface
usesWinapi.Windows,Vcl.Forms,vcl.Graphics,Vcl.ExtCtrls, System.SysUtils,VFrames,VSample,System.Classes,Vcl.StdCtrls,ZXing.ReadResult,ZXing.BarCodeFormat,ZXing.ScanManager;typeTZXingBarCode=class  //Scan By VideoprivateFTimer : TTimer;FImage : TImage;FOffset : Integer;FBitmap : TBitmap; //临时获取图片
    FVideoImage : TVideoImage;FDeviceName : string;FDevices : TStringlist;FScaning : Boolean;FData : string;FDefineDevice:Boolean; //是否指定摄像头
    FMemo:TMemo;publicprocedure Start;procedure Stop;protectedprocedure NewVideoFrame(Sender : TObject; Width, Height: integer; DataPtr: pointer);virtual;procedure CustomTimer(Sender:TObject);virtual;procedure DrawLine(ASrcPoint,ADesPoint:TPoint);virtual;publicproperty Status:Boolean read FScaning write FScaning;property Data : string read FData write FData;property Offset:Integer read FOffset write FOffset;constructor Create(AImage:TImage;ADisplay:TMemo;ADeviceName:string); overload;constructor Create(AImage:TImage;ADisplay:TMemo); overload;destructor Destroy; override;end;
typeTZXingReadImage=class //scan by pictureprivateFImage : TImage;publicfunction GetValue:string;constructor Create(AImage:TImage);destructor Destroy; override;end;
implementation{ TZXingBarCode }constructor TZXingBarCode.Create(AImage: TImage;ADisplay:TMemo;ADeviceName:string);
beginif ADeviceName='' thenraise Exception.Create('请指定摄像头!');FDeviceName := ADeviceName;Create(AImage,ADisplay);FDefineDevice := True;
end;constructor TZXingBarCode.Create(AImage: TImage;ADisplay:TMemo);
beginif not Assigned(AImage) thenraise Exception.Create('Image is null.');FImage := AImage;FDefineDevice := False;FMemo := ADisplay;FTimer := TTimer.Create(nil);FTimer.Interval :=500;FTimer.Enabled := False;FTimer.OnTimer := CustomTimer;FBitmap := TBitmap.Create;FBitmap.PixelFormat := pf24bit;FVideoImage := TVideoImage.Create;FVideoImage.OnNewVideoFrame := NewVideoFrame;FOffset := 20;
end;procedure TZXingBarCode.CustomTimer(Sender: TObject);
varpOri,pDesH,pDesV:TPoint;
beginwith FImage dobeginCanvas.Pen.Color := clWebGreen;Canvas.Pen.Width := 3;//  Canvas.pen.Mode := pmXor;
pOri := Point(10,10);pDesH := Point(pOri.X+FOffset,pOri.Y);pDesV := Point(pOri.X,pOri.Y+FOffset);DrawLine(pOri,pDesH);DrawLine(pOri,pDesV);pOri := Point(width-10,10);pDesH := Point(pOri.X-FOffset,pOri.Y);pDesV := Point(pOri.X,pOri.Y+FOffset);DrawLine(pOri,pDesH);DrawLine(pOri,pDesV);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesV.X,pDesV.Y);pOri := Point(width-10,Height-10);pDesH := Point(pOri.X-FOffset,pOri.Y);pDesV := Point(pOri.X,pOri.Y-FOffset);DrawLine(pOri,pDesH);DrawLine(pOri,pDesV);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesV.X,pDesV.Y);pOri := Point(10,Height-10);pDesH := Point(pOri.X+FOffset,pOri.Y);pDesV := Point(pOri.X,pOri.Y-FOffset);DrawLine(pOri,pDesH);DrawLine(pOri,pDesV);DrawLine(pOri,pDesH);DrawLine(pOri,pDesV);// Canvas.Pen.Mode := pmCopy;end;end;destructor TZXingBarCode.Destroy;
beginFTimer.Enabled := False;FreeAndNil(FVideoImage);FBitmap.Free;FTimer.Free;inherited;
end;procedure TZXingBarCode.DrawLine(ASrcPoint, ADesPoint: TPoint);
beginFImage.Canvas.MoveTo(ASrcPoint.X,ASrcPoint.Y);FImage.Canvas.LineTo(ADesPoint.X,ADesPoint.Y);
end;procedure TZXingBarCode.NewVideoFrame(Sender: TObject; Width, Height: integer;DataPtr: pointer);
varAScanManager : TScanManager;AReadResult : TReadResult;
beginAScanManager := nil;AReadResult := nil;tryFVideoImage.GetBitmap(FBitmap);FImage.Picture.Assign(FBitmap);//scan code ,如果为 TBarcodeFormat.Auto会报错tryAScanManager := TScanManager.Create(TBarcodeFormat.QR_CODE,nil);AReadResult := AScanManager.Scan(FBitmap);if Assigned(AReadResult) thenbeginData := AReadResult.text;if (Data<>'') and  Assigned(FMemo) thenFMemo.Lines.Add(Data);end;finallyFreeAndNil(AScanManager);FreeAndNil(AReadResult);end;finallyend;Application.ProcessMessages;
end;procedure TZXingBarCode.Start;
beginif FScaning then Exit;FDevices := TStringList.Create;tryFVideoImage.GetListOfDevices(FDevices);if FDevices.Count=0 thenraise Exception.Create('没有可用的摄像头.');if FDefineDevice thenbeginif FDevices.IndexOf(FDeviceName)=-1 thenraise Exception.Create('传入的摄像头不存在!');end elsebeginFDeviceName := FDevices[0];//第一个摄像头end;finallyFDevices.Free;end;FScaning := FVideoImage.VideoStart(FDeviceName)=0;//返回0表示成功FTimer.Enabled := True;
end;procedure TZXingBarCode.Stop;
beginFVideoImage.VideoStop;FScaning := False;FTimer.Enabled := False;
end;{ TZXingReadImage }constructor TZXingReadImage.Create(AImage: TImage);
beginif not Assigned(AImage) thenraise Exception.Create('not define image.');FImage := AImage;
end;destructor TZXingReadImage.Destroy;
begininherited;
end;function TZXingReadImage.GetValue: string;
varAReadResult: TReadResult;AScanManager: TScanManager;Abmp:VCL.Graphics.TBitmap; // just to be sure we are really using VCL bitmaps
beginAReadResult := nil;AScanManager := nil;Abmp := nil;tryAbmp:= TBitmap.Create;Abmp.assign (FImage.Picture.Graphic);AScanManager := TScanManager.Create(TBarcodeFormat.Auto, nil);AReadResult := AScanManager.Scan(Abmp);if AReadResult<>nil thenResult := AReadResult.textelseResult := 'Unreadable!';finallyAScanManager.Free;AReadResult.Free;end;end;end.

unit uMain;interfaceusesWinapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ExtCtrls,Vcl.Imaging.jpeg,uScanBarCode,vcl.imaging.pngImage;typeTForm1 = class(TForm)Image1: TImage;btnGenerateBar: TSpeedButton;Edit1: TEdit;Label1: TLabel;cmbLevel: TComboBox;Label2: TLabel;BitBtn1: TBitBtn;btnStart: TBitBtn;btnStop: TBitBtn;Memo1: TMemo;btnScanFile: TBitBtn;Timer1: TTimer;procedure btnGenerateBarClick(Sender: TObject);procedure BitBtn1Click(Sender: TObject);procedure btnStartClick(Sender: TObject);procedure btnStopClick(Sender: TObject);procedure btnScanFileClick(Sender: TObject);procedure Timer1Timer(Sender: TObject);private{ Private declarations }FScan:TZXingBarCode;public{ Public declarations }procedure CreateBarCode();end;varForm1: TForm1;implementation{$R *.dfm}
uses uBarcode;
varoffset:Integer=20;
procedure TForm1.BitBtn1Click(Sender: TObject);
varpOri,pDesH,pDesV:TPoint;
beginwith image1 dobeginCanvas.Pen.Color := clGreen;Canvas.Pen.Width := 2;Canvas.pen.Mode := pmXor;pOri := Point(10,10);pDesH := Point(pOri.X+offset,pOri.Y);pDesV := Point(pOri.X,pOri.Y+offset);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesH.X,pDesH.Y);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesV.X,pDesV.Y);pOri := Point(width-10,10);pDesH := Point(pOri.X-offset,pOri.Y);pDesV := Point(pOri.X,pOri.Y+offset);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesH.X,pDesH.Y);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesV.X,pDesV.Y);pOri := Point(width-10,Height-10);pDesH := Point(pOri.X-offset,pOri.Y);pDesV := Point(pOri.X,pOri.Y-offset);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesH.X,pDesH.Y);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesV.X,pDesV.Y);pOri := Point(10,Height-10);pDesH := Point(pOri.X+offset,pOri.Y);pDesV := Point(pOri.X,pOri.Y-offset);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesH.X,pDesH.Y);Canvas.MoveTo(pOri.X,pOri.Y);Canvas.LineTo(pDesV.X,pDesV.Y);//Canvas.Pen.Mode := pmCopy;end;
end;procedure TForm1.btnScanFileClick(Sender: TObject);
varADlg:TOpenDialog;AReader:TZXingReadImage;
beginADlg := TOpenDialog.Create(self);tryADlg.Filter :='png图片|*.png|jpg图片|*.jpg|jpeg图片|*.jpeg|bitmap|*.bmp';ADlg.DefaultExt :='.bmp';if not ADlg.Execute then exit;if ADlg.FileName='' then Exit;tryImage1.Picture.LoadFromFile(ADlg.FileName);except on E: Exception doraise Exception.Create(e.Message);end;tryAReader:= TZXingReadImage.Create(Image1);Memo1.Lines.Text := AReader.GetValue;finallyAReader.Free;end;finallyADlg.Free;end;
end;procedure TForm1.btnStartClick(Sender: TObject);
beginif not Assigned(FScan) thenFScan := TZXingBarCode.Create(Image1,Memo1);FScan.Start;Timer1.Enabled := true;btnStart.Enabled :=not FScan.Status;btnStop.Enabled := FScan.Status;end;procedure TForm1.btnStopClick(Sender: TObject);
beginif Assigned(FScan) thenbeginFScan.Stop;Timer1.Enabled := false;btnStart.Enabled :=True;btnStop.Enabled := False;FreeAndNil(FScan);Image1.Picture := nil;end;
end;procedure TForm1.CreateBarCode;
varzint:TZint;
beginzint := TZint.Create(Edit1.Text,Image1,TZintLevel(cmbLevel.ItemIndex+1));tryzint.ShowBarCode;finallyzint.Free;end;end;procedure TForm1.btnGenerateBarClick(Sender: TObject);
beginCreateBarCode();
end;procedure TForm1.Timer1Timer(Sender: TObject);
beginTimer1.Enabled := False;tryif Assigned(FScan) and (FScan.Data<>'') thenbeginShowMessage('process data:'+FScan.Data);FScan.Data:='';end;finallyTimer1.Enabled := True;end;
end;end.