Zint用于产生二维码。
Zxing用读取二维码。
VFrames.pas和VSample.pas用于摄像头。
另附带摄像头相关的类库，也可用开源的dspack也可用于摄像头的需求。
以上为开源的信息，请在sourceforge.net上下载。
本例用zint.dll的版本为2.6.0.
请在项目根目录下如zxing中的Classes文件夹及里面所有的文件。
设置此项目引用的文件，由于zxing中区分vcl和fmx，本例用到VCL,故把USE_VCL_BITMAP的编译选项加上去：
项目层次：
VFrames.pas
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 usually is fast enough to simulate running video. No audio support. History Version 1.6 2012-07-09 Support for 8-bit Grayscale images. Reduces time for image expansion for some types of compressions. (But not for all, e.g. RGB!) Some memory leaks fixed. Version 1.5 GDI+ support for MJPG, if GDI+ available YUY2 relaxed check of data size to support 1280*720 video size for Microsoft LifeCam Cinema 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, Math, VSample; CONST CBufferCnt = 3; // Triple-Buffer 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; 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 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; 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); public constructor 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 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; // 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 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; fBitmapGray := 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; // JPG.Performance := jpBestSpeed; MemStream := TMemoryStream.Create; fGray8Bit := false; FOR i := 0 TO 255 DO BEGIN GrayConvR[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); 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); 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; 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; // 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; PrepareGrayBMP(FBitmapGray, W, 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; // Create an 8bit grayscale palette image with width W and Height H. PROCEDURE TVideoImage.PrepareGrayBMP(VAR BM : TBitmap; W, H: integer); TYPE TLogPal = packed record palVersion: Word; palNumEntries: Word; palPalEntry: array[0..255] of TPaletteEntry; // In contrast to original declaration uses 255 instead of 0 end; VAR Pal : TLogPal; _Pal : tagLogPalette absolute Pal; // Trick! ;) dw : LongWord; BEGIN WITH Pal DO BEGIN palVersion:=$300; palNumEntries:=256; FOR dw := 0 TO 255 DO palPalEntry[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; BEGIN IF BM24.PixelFormat = pf8bit then begin BMGray.assign(BM24); exit; end; if (BM24.Width <> BMGray.Width) or (BM24.Height <> BMGray.Height) or (BMGray.PixelFormat <> pf8bit) then PrepareGrayBMP(BMGray, BM24.Width, bm24.Height); { This is the do-it-yourself way of converting RGB to GrayScale: FOR Y := BM24.height-1 DOWNTO 0 do begin p24 := BM24.ScanLine[Y]; p8 := BMGray.ScanLine[Y]; X3 := 0; FOR X := 0 TO BMGray.Width-1 DO begin p8^[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; 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); ValueL_255[i] := Min(255, round(i * 298.082 / 255)); 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.I420_to_Gray8Bit(pData: pointer); // http://en.wikipedia.org/wiki/YCbCr var Y : integer; pY : pbyte; begin pY := pData; FOR Y := 0 TO fBitmapGray.Height-1 DO begin move(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 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.YUY2_to_Gray8Bit(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 X, Y : integer; ps : pbyte; pf : ^byte; begin pf := pData; FOR Y := 0 TO fBitmapGray.Height-1 DO BEGIN ps := fBitmapGray.ScanLine[Y]; FOR X := 0 TO (fBitmapGray.Width div 2)-1 DO begin ps^ := pf^; Inc(ps); Inc(pf, 2); ps^ := pf^; Inc(ps); Inc(pf, 2); end; END; end; procedure TVideoImage.RGB_to_Gray8Bit(pData: pointer); type TRGB = ARRAY[0..5] OF byte; TPTRGB = ^TRGB; TWordArr = ARRAY[0..5759] OF word; TPTWordArr = ^TWordArr; VAR X, Y : integer; p8 : TPTWordArr; pf : TPTRGB; begin pf := pData; FOR Y := fBitmapGray.height-1 DOWNTO 0 do begin p8 := fBitmapGray.ScanLine[Y]; FOR X := 0 TO fBitmapGray.Width div 2-1 DO begin p8^[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 available if assigned(fDisplayCanvas) then begin IF not fImageUnpacked then UnpackFrame(fImagePtrSize[fImagePtrIndex], fImagePtr[fImagePtrIndex]); IF fDisplayCanvas.LockCount < 1 then begin fDisplayCanvas.lock; try IF fGray8Bit then fDisplayCanvas.Draw(0, 0, fBitmapGray) else 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 begin if fGray8Bit then RGB_to_Gray8Bit(pData) // Okay, this is when Grayscale is much slower than color :( else move(pData^, FBitmap.scanline[fHeight-1]^, Size); end else Unknown := true; END; FourCC_YUY2, FourCC_YUYV, FourCC_YUNV : BEGIN Unknown := (Size <> fWidth*fHeight*2); IF Unknown then begin // 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) then Unknown := (Size div (2 * fWidth)) mod 4 <> 0; // Width a multiple of 4? Maybe OK. end; IF not(Unknown) then begin IF fGray8Bit then YUY2_to_Gray8Bit(pData) else YUY2_to_RGB(pData); end; END; FourCC_MJPG : BEGIN try MemStream.Clear; MemStream.SetSize(Size); MemStream.Position := 0; MemStream.WriteBuffer(pData^, Size); MemStream.Position := 0; JPG.Grayscale := fGray8Bit; JPG.LoadFromStream(MemStream); if fGray8Bit then FBitmapGray.Canvas.Draw(0, 0, JPG) else FBitmap.Canvas.Draw(0, 0, JPG); except Unknown := true; end; END; FourCC_I420, FourCC_YV12, FourCC_IYUV : BEGIN Unknown := (Size <> (fWidth*fHeight*3) div 2); IF not Unknown then IF fGray8Bit then 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 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]); if fGray8Bit then 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); 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; PrepareGrayBMP(FBitmapGray, W, 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; PrepareGrayBMP(FBitmapGray, W, H); END; END; end.
VSample.pas
unit VSample; (****************************************************************************** VSample.pas Class TVideoSample About The TVideoSample class provides access to WebCams and similar Video-capture devices 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 samples are 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/delphi History Version 1.22 2012-07-08 (Fixed some memory leaks. List of supported video sizes/compressions corrected) Version 1.21 06.05.2012 (ansichar instead of char) Version 1.2 23.08.2009 Version 1.1 07.09.2008 Version 1.03 30.08.2008 Version 1.02 26.07.2008 Version 1.01 03.05.2008 Version 1.0 16.01.2006 Contact: michael@grizzlymotion.com Copyright Portions 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. 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, SysUtils, Classes, ActiveX, Forms, {$ifdef DXErr} DXErr9, {$endif} DirectShow9; { $ define REGISTER_FILTERGRAPH} CONST WM_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)); TYPE TPLAYSTATE = (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. TYPE TVideoSampleCallBack= 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= class CallBack : 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 = RECORD Width, 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) private ghApp : 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 video FUNCTION 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; implementation FUNCTION TGUIDEqual(const TG1, TG2 : TGUID): boolean; BEGIN Result := CompareMem(@TG1, @TG2, SizeOf(TGUID)); END; {TGUIDEqual} { Get a list of all capture devices installed } FUNCTION GetCaptureDeviceList(VAR SL: TStringList): HResult; VAR pDevEnum : 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; VAR pMoniker : IMoniker; pPropertyBag : IPropertyBag; v : OLEvariant; cFetched : ulong; BEGIN Result := false; Name := ''; pMoniker := nil; IF (S_OK = (pClassEnum.Next (1, pMoniker, @cFetched))) THEN BEGIN pPropertyBag := nil; if S_OK = pMoniker.BindToStorage(nil, nil, IPropertyBag, pPropertyBag) then begin if S_OK = pPropertyBag.Read('FriendlyName', v, nil) then begin Name := v; Result := true; end; end; END; END; {GetNextDeviceName} begin Result := S_FALSE; if not(assigned(SL)) then SL := TStringlist.Create; try SL.Clear; except exit; end; // Create the system device enumerator Result := CoCreateInstance (CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC_SERVER, IID_ICreateDevEnum, pDevEnum); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then begin // Couldn't create system enumerator! exit; end; // Create an enumerator for the video capture devices pClassEnum := nil; Result := pDevEnum.CreateClassEnumerator (CLSID_VideoInputDeviceCategory, pClassEnum, 0); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then begin // 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) then begin // No video capture device was detected. exit; end; WHILE GetNextDeviceName(st) DO SL.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; var BufferLen: integer; ppBuffer : pbyte; begin BufferLen := pSample.GetSize; if BufferLen > 0 then begin pSample.GetPointer(ppBuffer); {*} if @CallBack = nil then 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; begin if BufferLen > 0 then begin if @CallBack = nil then 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); begin ghApp := 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; VAR MT: _AMMediaType; BEGIN //--- Create the filter graph Result := CoCreateInstance(CLSID_FilterGraph, nil, CLSCTX_INPROC, IID_IGraphBuilder, pIGraphBuilder); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; //--- Create Sample grabber Result := CoCreateInstance(CLSID_SampleGrabber, nil, CLSCTX_INPROC_SERVER, IBaseFilter, piBFSampleGrabber); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; Result := CoCreateInstance(CLSID_NullRenderer, nil, CLSCTX_INPROC_SERVER, IID_IBaseFilter, pIBFNullRenderer); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; Result := piBFSampleGrabber.QueryInterface(IID_ISampleGrabber, pISampleGrabber); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; pISampleGrabber.SetBufferSamples(false); // No buffering required in this demo //--- Force 24bit color depth. (RGB24 erzwingen) IF ForceRGB then begin FillChar(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)) then exit; end; //--- Prepare Sample-Grabber Callback Object---- if not assigned(SGrabberCB) then begin SGrabberCB := 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 builder Result := CoCreateInstance(CLSID_CaptureGraphBuilder2, nil, CLSCTX_INPROC, IID_ICaptureGraphBuilder2, pICapGraphBuild2); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; // Obtain interfaces for media control and Video Window Result := pIGraphBuilder.QueryInterface(IID_IMediaControl, pIMediaControl); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; Result := pIGraphBuilder.QueryInterface(IID_IVideoWindow, pIVideoWindow); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; Result := pIGraphBuilder.QueryInterface(IID_IMediaEvent, pIMediaEventEx); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then exit; //--- Set the window handle used to process graph events Result := 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; VAR pDevEnum : ICreateDevEnum; pClassEnum : IEnumMoniker; Index : integer; Found : boolean; // see also: http://msdn.microsoft.com/en-us/library/ms787619.aspx FUNCTION CheckNextDeviceName(Name: string; VAR Found: boolean): HResult; VAR pMoniker : IMoniker; pPropertyBag : IPropertyBag; v : OLEvariant; cFetched : ulong; MonName : string; BEGIN Found := 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) THEN BEGIN Inc(Index); pPropertyBag := nil; Result := pMoniker.BindToStorage(nil, nil, IPropertyBag, pPropertyBag); if S_OK = Result then begin Result := pPropertyBag.Read('FriendlyName', v, nil); // BTW: Other useful parameter: 'DevicePath' if S_OK = Result then begin MonName := v; if (Uppercase(Trim(MonName)) = UpperCase(Trim(Name))) or ((Length(Name)=2) and (Name[1]='#') and (ord(Name[2])-48=Index)) then begin DeviceSelected := Trim(MonName); Result := pMoniker.BindToObject(nil, nil, IID_IBaseFilter, ppIBFVideoSource); Found := Result = S_OK; end; end; end; END; END; {CheckNextDeviceName} BEGIN DeviceSelected := ''; Index := 0; DeviceName := Trim(DeviceName); IF DeviceName = '' then DeviceName := '#1'; // Default: First device (Erstes Ger酹) if @ppIBFVideoSource = nil then begin result := E_POINTER; exit; end; // Create the system device enumerator Result := CoCreateInstance(CLSID_SystemDeviceEnum, nil, CLSCTX_INPROC, IID_ICreateDevEnum, pDevEnum); if (FAILED(Result)) then begin // Couldn't create system enumerator! exit; end; // Create an enumerator for the video capture devices pClassEnum := nil; Result := pDevEnum.CreateClassEnumerator (CLSID_VideoInputDeviceCategory, pClassEnum, 0); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then begin // 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) then begin // No video capture device was detected. result := E_FAIL; exit; end; Found := false; REPEAT try Result := CheckNextDeviceName(DeviceName, Found) except IF Result = 0 then result := E_FAIL; end; UNTIL Found or (Result <> S_OK); end; {ConnectToCaptureDevice} procedure TVideoSample.ResizeVideoWindow(); var rc : TRect; begin // Resize the video preview window to match owner window size if (pIVideoWindow) <> nil then begin // 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 window Result := pIVideoWindow.put_Owner(OAHWND(ghApp)); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then begin exit; end; // Set video window style Result := pIVideoWindow.put_WindowStyle(WS_CHILD or WS_CLIPCHILDREN); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then begin exit; 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 positioned Result := pIVideoWindow.put_Visible(TRUE); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if (FAILED(Result)) then begin exit; end; end; {SetupVideoWindow} FUNCTION TVideoSample.RestartVideoEx(Visible: boolean):HRESULT; VAR pCut, pTyp : pGuiD; { pAMVidControl: IAMVideoControl; pPin : IPin; } BEGIN if (pIAMVideoProcAmp = nil) then if not(S_OK = pIBFVideoSource.QueryInterface(IID_IAMVideoProcAmp, pIAMVideoProcAmp)) then pIAMVideoProcAmp := nil; if (pIKsPropertySet = nil) then if not(S_OK = pIBFVideoSource.QueryInterface(IID_IKsPropertySet, pIKsPropertySet)) then pIKsPropertySet := nil; // Add Capture filter to our graph. Result := pIGraphBuilder.AddFilter(pIBFVideoSource, Widestring('Video Capture')); if (FAILED(Result)) then begin // Couldn''t add the capture filter to the graph! exit; end; Result := pIGraphBuilder.AddFilter(piBFSampleGrabber, Widestring('Sample Grabber')); if (FAILED(Result)) then EXIT; if not(Visible) then begin Result := pIGraphBuilder.AddFilter(pIBFNullRenderer, WideString('Null Renderer')); if (FAILED(Result)) then EXIT; 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; try if Visible then 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); except Result := -1; end; if (FAILED(Result)) then begin // 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 position if Visible then begin Result := SetupVideoWindow(); if (FAILED(Result)) then begin // 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 graph try hr := AddGraphToRot(IUnknown(pIGraphBuilder), g_dwGraphRegister); except // Failed to register filter graph with ROT! end; if (FAILED(Result)) then begin // Failed to register filter graph with ROT! g_dwGraphRegister := 0; end; {$endif} // if Visible then begin // Start previewing video data Result := pIMediaControl.Run(); if (FAILED(Result)) then begin // Couldn't run the graph! end; end; // Remember current state g_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) then begin pTyp := 0; pPin := nil; Result := pICapGraphBuild2.FindPin(pIBFVideoSource, PINDIR_OUTPUT, PIN_CATEGORY_STILL, pTyp^, false, 0, pPin); if (SUCCEEDED(Result)) then Result := pAMVidControl.SetMode(pPin, VideoControlFlag_Trigger); end; *) Dispose(pTyp); Dispose(pCut); end; {RestartVideoEx} FUNCTION TVideoSample.RestartVideo: HRESULT; BEGIN Result := RestartVideoEx(FVisible); END; {RestartVideo} FUNCTION TVideoSample.StartVideo(CaptureDeviceName: string; Visible: boolean; VAR DeviceSelected: string):HRESULT; BEGIN pIBFVideoSource := nil; FVisible := Visible; // Attach the filter graph to the capture graph Result := pICapGraphBuild2.SetFiltergraph(pIGraphBuilder); if (FAILED(Result)) then begin // 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)) then begin exit; end; LoadListOfResolution; Result := RestartVideo; end; FUNCTION TVideoSample.PauseVideo: HResult; BEGIN IF g_psCurrent = PS_Paused then begin Result := S_OK; EXIT; end; IF g_psCurrent = PS_Running then begin Result := pIMediaControl.Pause; if Succeeded(Result) then g_psCurrent := PS_Paused; end else Result := S_FALSE; END; FUNCTION TVideoSample.ResumeVideo: HResult; BEGIN IF g_psCurrent = PS_Running then begin Result := S_OK; EXIT; end; IF g_psCurrent = PS_Paused then begin Result := pIMediaControl.Run; if Succeeded(Result) then g_psCurrent := PS_Running; end else Result := S_FALSE; END; FUNCTION TVideoSample.StopVideo: HResult; BEGIN // Stop previewing video data Result := pIMediaControl.StopWhenReady(); g_psCurrent := PS_Stopped; SetLength(FormatArr, 0); END; // Delete filter and pins bottom-up... PROCEDURE TVideoSample.DeleteBelow(const IBF: IBaseFilter); VAR hr : HResult; pins : IEnumPins; pIPinFrom, pIPinTo : IPin; fetched : ulong; pInfo : _PinInfo; BEGIN pIPinFrom := nil; pIPinTo := nil; hr := IBF.EnumPins(pins); WHILE (hr = NoError) DO BEGIN hr := pins.Next(1, pIPinFrom, @fetched); if (hr = S_OK) and (pIPinFrom <> nil) then BEGIN hr := pIPinFrom.ConnectedTo(pIPinTo); if (hr = S_OK) and (pIPinTo <> nil) then BEGIN hr := pIPinTo.QueryPinInfo(pInfo); if (hr = NoError) then BEGIN if pinfo.dir = PINDIR_INPUT then BEGIN DeleteBelow(pInfo.pFilter); pIGraphBuilder.Disconnect(pIPinTo); pIGraphBuilder.Disconnect(pIPinFrom); pIGraphBuilder.RemoveFilter(pInfo.pFilter); ENd; END; END; END; END; END; {DeleteBelow} PROCEDURE TVideoSample.DeleteCaptureGraph; BEGIN pIBFVideoSource.Stop; DeleteBelow(pIBFVideoSource); END; procedure TVideoSample.CloseInterfaces; begin if (pISampleGrabber <> nil) then pISampleGrabber.SetCallback(nil, 1); // Stop previewing data if (pIMediaControl <> nil) then pIMediaControl.StopWhenReady(); g_psCurrent := PS_Stopped; // Stop receiving events if (pIMediaEventEx <> nil) then pIMediaEventEx.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) then begin pIVideoWindow.put_Visible(FALSE); pIVideoWindow.put_Owner(OAHWND(nil)); end; {$ifdef REGISTER_FILTERGRAPH} // Remove filter graph from the running object table if (g_dwGraphRegister<>nil) then RemoveGraphFromRot(g_dwGraphRegister); {$endif} end; function TVideoSample.GetImageBuffer(VAR pb : pbytearray; var Size: integer): HResult; VAR NewSize : integer; begin Result := pISampleGrabber.GetCurrentBuffer(NewSize, nil); if (Result <> S_OK) then EXIT; if (pb <> nil) then begin if Size <> NewSize then begin try FreeMem(pb, Size); except end; pb := nil; Size := 0; end; end; Size := NewSize; IF Result = S_OK THEN BEGIN if pb = nil then GetMem(pb, NewSize); Result := pISampleGrabber.GetCurrentBuffer(NewSize, pb); END; end; FUNCTION TVideoSample.SetPreviewState(nShow: boolean): HRESULT; BEGIN Result := S_OK; // If the media control interface isn't ready, don't call it if (pIMediaControl = nil) then exit; if (nShow) then begin if (g_psCurrent <> PS_Running) then begin // Start previewing video data Result := pIMediaControl.Run(); g_psCurrent := PS_Running; end; end else 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; VAR pProp : ISpecifyPropertyPages; c : tagCAUUID; begin pProp := nil; Result := IBF.QueryInterface(ISpecifyPropertyPages, pProp); if Result = S_OK then begin Result := pProp.GetPages(c); if (Result = S_OK) and (c.cElems > 0) then begin Result := OleCreatePropertyFrame(ghApp, 0, 0, FilterName, 1, @IBF, c.cElems, c.pElems, 0, 0, nil); CoTaskMemFree(c.pElems); end; end; end; FUNCTION TVideoSample.ShowPropertyDialog: HResult; VAR FilterInfo : FILTER_INFO; begin Result := pIBFVideoSource.QueryFilterInfo(FilterInfo); if not(Failed(Result)) then Result := ShowPropertyDialogEx(pIBFVideoSource, FilterInfo.achName); end; FUNCTION TVideoSample.GetCaptureIAMStreamConfig(VAR pSC: IAMStreamConfig): HResult; BEGIN pSC := nil; Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_capture, @MEDIATYPE_Video, pIBFVideoSource, IID_IAMStreamConfig, pSC); END; FUNCTION TVideoSample.ShowPropertyDialog_CaptureStream: HResult; VAR pSC : IAMStreamConfig; BEGIN pIMediaControl.Stop; Result := GetCaptureIAMStreamConfig(pSC); if Result = S_OK then Result := ShowPropertyDialogEx(pSC, ''); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} pIMediaControl.Run; END; (* PROCEDURE DumpMediaType(const mt: TAMMediaType; VAR Dump: TStringList); begin Dump.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; VAR pSC : IAMStreamConfig; VideoStreamConfigCaps : TVideoStreamConfigCaps; p : ^TVideoStreamConfigCaps; ppmt : PAMMediaType; i, j, piCount, piSize : integer; Swap : boolean; FM : TFormatInfo; BEGIN SetLength(FormatArr, 0); Result := GetCaptureIAMStreamConfig(pSC); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} IF Result = S_OK then Result := pSC.GetNumberOfCapabilities(piCount, piSize); j := 0; if Result = S_OK then begin FOR i := 0 TO piCount-1 DO begin p := @VideoStreamConfigCaps; Result := pSC.GetStreamCaps(i, ppmt, p^); IF Succeeded(Result) then IF not(IsEqualGUID(ppmt^.formattype, KSDATAFORMAT_SPECIFIER_VIDEOINFO2)) then // Only first part of info is relevant begin SetLength(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 height IF j > 1 then begin REPEAT Swap := false; FOR i := 0 TO j-2 DO IF (FormatArr[i].Width > FormatArr[i+1].Width) or (((FormatArr[i].Width = FormatArr[i+1].Width)) and ((FormatArr[i].Height > FormatArr[i+1].Height))) then begin Swap := 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". VAR pSC : IAMStreamConfig; BEGIN IF (ListIndex < 0) or (ListIndex >= Length(FormatArr)) then begin Result := 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; VAR pSC : IAMStreamConfig; ppmt : PAMMediaType; pmt : _AMMediaType; VI : VideoInfo; VIH : VideoInfoHeader; BEGIN Width := 0; Height := 0; //pIMediaControl.Stop; // Crash with FakeWebCam. Thanks to "Zacherl" from Delphi-Praxis http://www.delphipraxis.net/1165063-post16.html pIBFVideoSource.Stop; // nicht zwingend n飆ig Result := GetCaptureIAMStreamConfig(pSC); {$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif} if Result = S_OK then begin Result := pSC.GetFormat(ppmt); pmt := ppmt^; if TGUIDEqual(ppmt.formattype, FORMAT_VideoInfo) then begin FillChar(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; BEGIN Result := S_False; if pIAMVideoProcAmp = nil then exit; Result := pIAMVideoProcAmp.GetRange(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags); pActual := pDefault; IF Result = S_OK then Result := pIAMVideoProcAmp.Get(Prop, pActual, pCapsFlags) END; FUNCTION TVideoSample.SetVideoPropAmpEx( Prop : TVideoProcAmpProperty; pCapsFlags : TVideoProcAmpFlags; pActual : longint): HResult; BEGIN Result := S_False; if pIAMVideoProcAmp = nil then exit; Result := pIAMVideoProcAmp.Set_(Prop, pActual, pCapsFlags) END; PROCEDURE TVideoSample.GetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; VAR AcPerCent: integer); VAR pMin, pMax, pSteppingDelta, pDefault : longint; pCapsFlags : TVideoProcAmpFlags; pActual : longint; BEGIN IF GetVideoPropAmpEx(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags, pActual) = S_OK THEN BEGIN AcPerCent := round(100 * (pActual-pMin)/(pMax-pMin)); END ELSE AcPerCent := -1; END; PROCEDURE TVideoSample.SetVideoPropAmpPercent(Prop: TVideoProcAmpProperty; AcPerCent: integer); VAR pMin, pMax, pSteppingDelta, pDefault : longint; pCapsFlags : TVideoProcAmpFlags; pActual : longint; d : double; BEGIN IF GetVideoPropAmpEx(Prop, pMin, pMax, pSteppingDelta, pDefault, pCapsFlags, pActual) = S_OK THEN BEGIN IF (AcPercent < 0) or (AcPercent > 100) then begin pActual := pDefault; end else begin d := (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); VAR pBV : IBasicVideo; BEGIN Width := 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; VAR pVfw : IAMVfwCaptureDialogs; BEGIN pVfw := nil; pIMediaControl.Stop; Result := pICapGraphBuild2.FindInterface(@PIN_CATEGORY_CAPTURE, @MEDIATYPE_Video, pIBFVideoSource, IID_IAMVfwCaptureDialogs, pVfW); if not(Succeeded(Result)) then // Retry Result := pICapGraphBuild2.queryinterface(IID_IAMVfwCaptureDialogs, pVfw); if not(Succeeded(Result)) then // Retry Result := pIGraphBuilder.queryinterface(IID_IAMVfwCaptureDialogs, pVfw); if (SUCCEEDED(Result)) THEN BEGIN // 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; BEGIN Result := 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; BEGIN Result := 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); BEGIN CallBack := CB; SGrabberCB.FSampleGrabberCB.CallBack := CB; END; FUNCTION TVideoSample.GetPlayState: TPlayState; BEGIN Result := g_psCurrent; END; PROCEDURE TVideoSample.GetListOfVideoSizes(VidSize: TStringList); VAR i : integer; BEGIN try IF not(assigned(VidSize)) then VidSize := TStringList.Create; VidSize.Clear; except exit; end; IF g_psCurrent < PS_Paused then exit; FOR i := 0 TO Length(FormatArr)-1 DO VidSize.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; VAR pMoniker : 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))) then begin result := E_FAIL; exit; end; { wsprintfW(wsz, 'FilterGraph %08x pid %08x ', 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) DO wsz[i-1] := widechar(sz[i]); hr := CreateItemMoniker('!', wsz, pMoniker); if (SUCCEEDED(hr)) then begin // 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); VAR pROT : IRunningObjectTable; begin if (SUCCEEDED(GetRunningObjectTable(0, pROT))) then begin pROT.Revoke(pdwRegister); // pROT._Release(); end; end; {$endif} (* FUNCTION TVideoSample.GetStreamInfoTest(VAR Width, Height: integer; VAR FourCC: dword): HResult; VAR pSC : IAMStreamConfig; ppmt : PAMMediaType; pmt : _AMMediaType; VI : VideoInfo; VIH : VideoInfoHeader; BEGIN Width := 0; Height := 0; pIMediaControl.Stop; pIBFVideoSource.Stop; // nicht zwingend n飆ig pSC := 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 then begin pSC.GetFormat(ppmt); pmt := ppmt^; if TGUIDEqual(ppmt.formattype, FORMAT_VideoInfo) then begin FillChar(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; begin try SetPreviewState(false); pIMediaControl.Stop; pIBFVideoSource.Stop; DeleteCaptureGraph; closeInterfaces; if assigned(SGrabberCB) and assigned(TSampleGrabberCB(SGrabberCB).FSampleGrabberCB) then begin TSampleGrabberCB(SGrabberCB).FSampleGrabberCB.Free; TSampleGrabberCB(SGrabberCB).FSampleGrabberCB := nil; end; finally try inherited destroy; except end; end; end; end.
uBarcode.pas 产生二维码类
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_H 3、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。 } type TZintLevel=(LEVEL_L=1,LEVEL_M,LEVEL_Q,LEVEL_H); TZintSymbol = packed record symbology: Integer; height: Integer; whitespace_ Integer; border_ 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; 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 189 errtxt: array[0..99] of AnsiChar; bitmap: PAnsiChar; bitmap_ Integer; bitmap_height: Integer; bitmap_byte_length: Cardinal; dot_size: Single; rendered: Pointer; debug: Integer; end; PZintSymbol = ^TZintSymbol; Type TZint=class(Tobject) private FSymbol : 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; public procedure ShowBarCode; public constructor 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 codes BARCODE_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); begin if not Assigned(AImage) then raise 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) then raise Exception.Create('Generate BarCode Failed!'); FSymbol.symbology := FType; end; destructor TZint.Destroy; begin FBitmap.Free; FBitmap := nil; ZBarcodeDelete; inherited; end; procedure TZint.ShowBarCode; var AErrNumber : integer; AErrMsg : string; begin AErrNumber := 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 then begin ZBarcode_To_Bitmap; FImage.Picture.Bitmap.Canvas.StretchDraw(Rect(10, 10, FImage.Width - 10, FImage.Height - 10), FBitmap); end else raise Exception.Create('编码时发生错误：' + AErrMsg); end; function TZint.ZBarcodeCreate:PZintSymbol; begin Result := ZBarcode_Create; end; procedure TZint.ZBarcodeDelete; begin ZBarcode_Delete(FSymbol); end; function TZint.ZBarcodeEncodeAndOutput(out AErr:string): Integer; begin Result := ZBarcode_Encode_and_Buffer(FSymbol,PAnsiChar(FData),Length(FData),0); AErr := string(AnsiString(FSymbol.errtxt)); end; procedure TZint.ZBarcode_To_Bitmap; var SrcRGB: PRGBTriple; Row, RowWidth: Integer; begin FBitmap.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 do begin CopyMemory(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.
uScanBarCode.pas 扫描的类
unit uScanBarCode; interface uses Winapi.Windows,Vcl.Forms,vcl.Graphics,Vcl.ExtCtrls, System.SysUtils, VFrames,VSample,System.Classes,Vcl.StdCtrls, ZXing.ReadResult, ZXing.BarCodeFormat, ZXing.ScanManager; type TZXingBarCode=class //Scan By Video private FTimer : TTimer; FImage : TImage; FOffset : Integer; FBitmap : TBitmap; //临时获取图片 FVideoImage : TVideoImage; FDeviceName : string; FDevices : TStringlist; FScaning : Boolean; FData : string; FDefineDevice:Boolean; //是否指定摄像头 FMemo:TMemo; public procedure Start; procedure Stop; protected procedure NewVideoFrame(Sender : TObject; Width, Height: integer; DataPtr: pointer);virtual; procedure CustomTimer(Sender:TObject);virtual; procedure DrawLine(ASrcPoint,ADesPoint:TPoint);virtual; public property 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; type TZXingReadImage=class //scan by picture private FImage : TImage; public function GetValue:string; constructor Create(AImage:TImage); destructor Destroy; override; end; implementation { TZXingBarCode } constructor TZXingBarCode.Create(AImage: TImage;ADisplay:TMemo;ADeviceName:string); begin if ADeviceName='' then raise Exception.Create('请指定摄像头!'); FDeviceName := ADeviceName; Create(AImage,ADisplay); FDefineDevice := True; end; constructor TZXingBarCode.Create(AImage: TImage;ADisplay:TMemo); begin if not Assigned(AImage) then raise 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); var pOri,pDesH,pDesV:TPoint; begin with FImage do begin Canvas.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; begin FTimer.Enabled := False; FreeAndNil(FVideoImage); FBitmap.Free; FTimer.Free; inherited; end; procedure TZXingBarCode.DrawLine(ASrcPoint, ADesPoint: TPoint); begin FImage.Canvas.MoveTo(ASrcPoint.X,ASrcPoint.Y); FImage.Canvas.LineTo(ADesPoint.X,ADesPoint.Y); end; procedure TZXingBarCode.NewVideoFrame(Sender: TObject; Width, Height: integer; DataPtr: pointer); var AScanManager : TScanManager; AReadResult : TReadResult; begin AScanManager := nil; AReadResult := nil; try FVideoImage.GetBitmap(FBitmap); FImage.Picture.Assign(FBitmap); //scan code ,如果为 TBarcodeFormat.Auto会报错 try AScanManager := TScanManager.Create(TBarcodeFormat.QR_CODE,nil); AReadResult := AScanManager.Scan(FBitmap); if Assigned(AReadResult) then begin Data := AReadResult.text; if (Data<>'') and Assigned(FMemo) then FMemo.Lines.Add(Data); end; finally FreeAndNil(AScanManager); FreeAndNil(AReadResult); end; finally end; Application.ProcessMessages; end; procedure TZXingBarCode.Start; begin if FScaning then Exit; FDevices := TStringList.Create; try FVideoImage.GetListOfDevices(FDevices); if FDevices.Count=0 then raise Exception.Create('没有可用的摄像头.'); if FDefineDevice then begin if FDevices.IndexOf(FDeviceName)=-1 then raise Exception.Create('传入的摄像头不存在!'); end else begin FDeviceName := FDevices[0];//第一个摄像头 end; finally FDevices.Free; end; FScaning := FVideoImage.VideoStart(FDeviceName)=0;//返回0表示成功 FTimer.Enabled := True; end; procedure TZXingBarCode.Stop; begin FVideoImage.VideoStop; FScaning := False; FTimer.Enabled := False; end; { TZXingReadImage } constructor TZXingReadImage.Create(AImage: TImage); begin if not Assigned(AImage) then raise Exception.Create('not define image.'); FImage := AImage; end; destructor TZXingReadImage.Destroy; begin inherited; end; function TZXingReadImage.GetValue: string; var AReadResult: TReadResult; AScanManager: TScanManager; Abmp:VCL.Graphics.TBitmap; // just to be sure we are really using VCL bitmaps begin AReadResult := nil; AScanManager := nil; Abmp := nil; try Abmp:= TBitmap.Create; Abmp.assign (FImage.Picture.Graphic); AScanManager := TScanManager.Create(TBarcodeFormat.Auto, nil); AReadResult := AScanManager.Scan(Abmp); if AReadResult<>nil then Result := AReadResult.text else Result := 'Unreadable!'; finally AScanManager.Free; AReadResult.Free; end; end; end.
uMain.pas 主单元文件
unit uMain; interface uses Winapi.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; type TForm1 = 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; var Form1: TForm1; implementation {$R *.dfm} uses uBarcode; var offset:Integer=20; procedure TForm1.BitBtn1Click(Sender: TObject); var pOri,pDesH,pDesV:TPoint; begin with image1 do begin Canvas.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); var ADlg:TOpenDialog; AReader:TZXingReadImage; begin ADlg := TOpenDialog.Create(self); try ADlg.Filter :='png图片|*.png|jpg图片|*.jpg|jpeg图片|*.jpeg|bitmap|*.bmp'; ADlg.DefaultExt :='.bmp'; if not ADlg.Execute then exit; if ADlg.FileName='' then Exit; try Image1.Picture.LoadFromFile(ADlg.FileName); except on E: Exception do raise Exception.Create(e.Message); end; try AReader:= TZXingReadImage.Create(Image1); Memo1.Lines.Text := AReader.GetValue; finally AReader.Free; end; finally ADlg.Free; end; end; procedure TForm1.btnStartClick(Sender: TObject); begin if not Assigned(FScan) then FScan := TZXingBarCode.Create(Image1,Memo1); FScan.Start; Timer1.Enabled := true; btnStart.Enabled :=not FScan.Status; btnStop.Enabled := FScan.Status; end; procedure TForm1.btnStopClick(Sender: TObject); begin if Assigned(FScan) then begin FScan.Stop; Timer1.Enabled := false; btnStart.Enabled :=True; btnStop.Enabled := False; FreeAndNil(FScan); Image1.Picture := nil; end; end; procedure TForm1.CreateBarCode; var zint:TZint; begin zint := TZint.Create(Edit1.Text,Image1,TZintLevel(cmbLevel.ItemIndex+1)); try zint.ShowBarCode; finally zint.Free; end; end; procedure TForm1.btnGenerateBarClick(Sender: TObject); begin CreateBarCode(); end; procedure TForm1.Timer1Timer(Sender: TObject); begin Timer1.Enabled := False; try if Assigned(FScan) and (FScan.Data<>'') then begin ShowMessage('process data:'+FScan.Data); FScan.Data:=''; end; finally Timer1.Enabled := True; end; end; end.
最终执行界面：
（根据内容产生条码）
打开摄像头扫描：
图片识别：
注意：在打开摄像头扫描时，如果TBarcodeFormat为AUTO时会莫名的报错。