Delphi 二维码产生和扫描
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 = ; // 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[..CBufferCnt] OF pointer; // Local copy of image data
fImagePtrSize : ARRAY[..CBufferCnt] OF integer;
fImagePtrIndex: integer;
fMessageHWND : HWND;
fMsgNewFrame : uint;
fOnNewFrame : TNewVideoFrameEvent;
AppEvent : TApplicationEvents;
IdleEventTick : cardinal;
ValueY_,
ValueU_,
ValueU_,
ValueV_,
ValueV_ : ARRAY[byte] OF integer;
ValueL_ : ARRAY[byte] OF byte;
ValueClip : ARRAY[-..] OF byte;
GrayConvR,
GrayConvG,
GrayConvB : ARRAY[..] 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 = $;
FourCC_YUYV = $;
FourCC_YUNV = $564E5559; FourCC_MJPG = $47504A4D; FourCC_I420 = $;
FourCC_YV12 = $;
FourCC_IYUV = $; 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 = then
begin
if f30FrameTick > then
fFPS := / (T1-f30FrameTick);
f30FrameTick := T1;
end; // frt 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+) mod CBufferCnt;
IF fImagePtrSize[i] <> Size then
begin
IF fImagePtrSize[i] > 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();
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 := ;
fHeight := ;
fFourCC := ;
FOR i := TO CBufferCnt- DO
BEGIN
fImagePtr[i] := nil;
fImagePtrSize[i] := ;
END;
fMsgNewFrame := wm_user+;
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 := TO DO
BEGIN
GrayConvR[i] := * i;
GrayConvG[i] := * i;
GrayConvB[i] := * i +;
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- DOWNTO DO
IF fImagePtrSize[i] <> then
begin
FreeMem(fImagePtr[i], fImagePtrSize[i]);
fImagePtr[i] := nil;
fImagePtrSize[i] := ;
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 := -;
MaxVal := -;
StepSize := ;
Default := ;
Actual := ;
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 := -;
MaxVal := -;
StepSize := ;
Default := ;
Actual := ;
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 := ;
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 := ;
fFrameCnt := ;
f30FrameTick := ;
fFPS := ;
fImageUnpacked := false; Result := ;
if assigned(VideoSample) then
VideoStop; VideoSample := TVideoSample.Create(Application.MainForm.Handle, false, , HR); // No longer force RGB24
try
hr := VideoSample.StartVideo(DeviceName, false, st) // Not visible. Displays itself...
except
hr := -;
end; if Failed(hr)
then begin
VideoStop;
// ShowMessage(DXGetErrorDescription9A(hr));
Result := ;
end
else begin
hr := VideoSample.GetStreamInfo(W, H, FourCC);
IF Failed(HR)
then begin
VideoStop;
Result := ;
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[..] 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:=$;
palNumEntries:=;
FOR dw := TO DO
palPalEntry[dw] := TPaletteEntry(dw * $);
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(, , BM24);
END; PROCEDURE TVideoImage.PrepareTables;
VAR
i : integer;
BEGIN
IF fYUY2TablesPrepared then
exit;
FOR i := TO 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_[i] := round(i * 298.082);
ValueU_[i] := round(i * -100.291);
ValueU_[i] := round(i * 516.412 - 276.836*);
ValueV_[i] := round(i * 408.583 - 222.921*);
ValueV_[i] := round(i * -208.120 + 135.576*);
ValueL_[i] := Min(, round(i * 298.082 / ));
END;
FillChar(ValueClip, SizeOf(ValueClip), #);
FOR i := TO DO
ValueClip[i] := i;
FOR i := TO DO
ValueClip[i] := ;
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 := TO fBitmap.Height- DO
BEGIN
ps := fBitmap.ScanLine[Y]; pU := pData;
Inc(pU, fBitmap.Width*(fBitmap.height+ Y div ));
pV := PU;
Inc(pV, fBitmap.Width*fBitmap.height div ); FOR X := TO (fBitmap.Width div )- DO
begin
L := ValueY_[pY^];
ps^ := ValueClip[(L + ValueU_[pU^] ) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueU_[pU^] + ValueV_[pV^]) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueV_[pV^]) div ];
Inc(ps);
Inc(pY); L := ValueY_[pY^];
ps^ := ValueClip[(L + ValueU_[pU^] ) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueU_[pU^] + ValueV_[pV^]) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueV_[pV^]) div ];
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 := TO fBitmapGray.Height- 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[..] OF byte;
VAR
L, X, Y : integer;
ps : pbyte;
pf : ^TFour;
begin
pf := pData;
PrepareTables;
FOR Y := TO fBitmap.Height- DO
BEGIN
ps := fBitmap.ScanLine[Y];
FOR X := TO (fBitmap.Width div )- DO
begin
L := ValueY_[pf^[]];
ps^ := ValueClip[(L + ValueU_[pf^[]] ) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueU_[pf^[]] + ValueV_[pf^[]]) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueV_[pf^[]]) div ];
Inc(ps); L := ValueY_[pf^[]];
ps^ := ValueClip[(L + ValueU_[pf^[]] ) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueU_[pf^[]] + ValueV_[pf^[]]) div ];
Inc(ps);
ps^ := ValueClip[(L + ValueV_[pf^[]]) div ];
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[..] OF byte;
VAR
X, Y : integer;
ps : pbyte;
pf : ^byte;
begin
pf := pData;
FOR Y := TO fBitmapGray.Height- DO
BEGIN
ps := fBitmapGray.ScanLine[Y];
FOR X := TO (fBitmapGray.Width div )- DO
begin
ps^ := pf^;
Inc(ps);
Inc(pf, );
ps^ := pf^;
Inc(ps);
Inc(pf, );
end;
END;
end; procedure TVideoImage.RGB_to_Gray8Bit(pData: pointer);
type
TRGB = ARRAY[..] OF byte;
TPTRGB = ^TRGB;
TWordArr = ARRAY[..] OF word;
TPTWordArr = ^TWordArr;
VAR
X, Y : integer;
p8 : TPTWordArr;
pf : TPTRGB;
begin
pf := pData; FOR Y := fBitmapGray.height- DOWNTO do
begin
p8 := fBitmapGray.ScanLine[Y];
FOR X := TO fBitmapGray.Width div - DO
begin
p8^[X] := ((GrayConvB[pf^[]] + GrayConvG[pf^[]] + GrayConvR[pf^[]]) and $FF00) +
(GrayConvB[pf^[]] + GrayConvG[pf^[]] + GrayConvR[pf^[]]) shr ;
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 < then
begin
fDisplayCanvas.lock;
try
IF fGray8Bit
then fDisplayCanvas.Draw(, , fBitmapGray)
else fDisplayCanvas.Draw(, , fBitmap);
finally
fDisplayCanvas.unlock;
end;
end;
end;
END; procedure TVideoImage.UnpackFrame(Size: integer; pData: pointer);
var
{f : file;}
Unknown : boolean;
FourCCSt: string[];
begin
IF pData = nil
then exit;
Unknown := false;
try
Case fFourCC OF
: BEGIN
IF (Size = fWidth*fHeight*)
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-]^, Size);
end
else Unknown := true;
END;
FourCC_YUY2,
FourCC_YUYV,
FourCC_YUNV : BEGIN
Unknown := (Size <> fWidth*fHeight*);
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 * ) then
Unknown := (Size div ( * fWidth)) mod <> ; // 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 := ;
MemStream.WriteBuffer(pData^, Size);
MemStream.Position := ;
JPG.Grayscale := fGray8Bit;
JPG.LoadFromStream(MemStream);
if fGray8Bit
then FBitmapGray.Canvas.Draw(, , JPG)
else FBitmap.Canvas.Draw(, , JPG);
except
Unknown := true;
end;
END;
FourCC_I420,
FourCC_YV12,
FourCC_IYUV : BEGIN
Unknown := (Size <> (fWidth*fHeight*) div );
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 =
then FourCCSt := 'RGB'
else begin
FourCCSt := ' ';
move(fFourCC, FourCCSt[], );
end;
FBitmap.Canvas.TextOut(, , 'Unknown compression');
FBitmap.Canvas.TextOut(, 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+;
WM_NewFrame = WM_User+; // 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:$;D2:$;D3:$;D4:($C0,$,$,$,$,$,$,$)); 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[..] 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 (, 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, );
{$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 > 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 := ;
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) zurkgelieferte 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 > then
begin
if @CallBack = nil
then SendMessage(Application.Mainform.handle, WM_NewFrame, BufferLen, integer(pBuffer))
else Callback(pbytearray(pBuffer), BufferLen);
end;
Result := ;
end; // ---= End of Sample Grabber callback routines =--------------------------- constructor TVideoSample.Create(VideoCanvasHandle: THandle; ForceRGB: boolean; WhichMethodToCallback: integer; VAR HR: HResult);
begin
ghApp := ; 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:=;
{$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), #);
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, );
{$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(, 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)=) and (Name[]='#') and (ord(Name[])-=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 := ;
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, );
{$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 = 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(, , 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 := -;
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 := ;
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, );
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(, 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, ); // 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, ); // 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 := ;
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 > ) then
begin
Result := OleCreatePropertyFrame(ghApp, , , FilterName, , @IBF, c.cElems, c.pElems, , , 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, );
Result := GetCaptureIAMStreamConfig(pSC);
{$ifdef DXErr} DXErrString := DXGetErrorDescription9A(Result); {$endif}
IF Result = S_OK then
Result := pSC.GetNumberOfCapabilities(piCount, piSize);
j := ;
if Result = S_OK then
begin
FOR i := TO piCount- 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+);
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, );
Inc(j);
end;
end;
end; // Simple sort by width and height
IF j > then
begin
REPEAT
Swap := false;
FOR i := TO j- DO
IF (FormatArr[i].Width > FormatArr[i+].Width) or
(((FormatArr[i].Width = FormatArr[i+].Width)) and ((FormatArr[i].Height > FormatArr[i+].Height)))
then
begin
Swap := true;
FM := FormatArr[i];
FormatArr[i] := FormatArr[i+];
FormatArr[i+] := 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 < ) 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 := ;
Height := ;
//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), #);
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();// 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( * (pActual-pMin)/(pMax-pMin));
END
ELSE AcPerCent := -;
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 < ) or (AcPercent > ) then
begin
pActual := pDefault;
end
else begin
d := (pMax-pMin)/*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 := ;
Height := ;
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 := TO Length(FormatArr)- 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[..] OF wchar;
hr : HResult;
dwRegister : integer absolute pdwregister;
i : integer;
BEGIN
{
if (!pUnkGraph || !pdwRegister)
return E_POINTER;
}
if (FAILED(GetRunningObjectTable(, pROT))) then
begin
result := E_FAIL;
exit;
end;
{
wsprintfW(wsz, 'FilterGraph %08x pid %08x\0', DWORD_PTR(pUnkGraph),
GetCurrentProcessId());
}
sz := 'FilterGraph ' + lowercase(IntToHex(integer((pUnkGraph)), ))+' pid '+
lowercase(IntToHex(GetCurrentProcessID,))+#;
fillchar(wsz, sizeof(wsz), #);
for i := to length(sz) DO
wsz[i-] := 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(, 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), #);
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();// 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=,LEVEL_M,LEVEL_Q,LEVEL_H);
TZintSymbol = packed record
symbology: Integer;
height: Integer;
whitespace_width: Integer;
border_width: Integer;
output_options: Integer;
fgcolour: array[..] of AnsiChar;
bgcolour: array[..] of AnsiChar;
outfile: array[..] of AnsiChar;
scale: Single;
option_: Integer; //容错级别
option_: Integer;
option_: Integer;
show_hrt: Integer;
input_mode: Integer;
eci: Integer;
text: array[..] of AnsiChar;
rows: Integer;
width: Integer;
primary: array[..] of AnsiChar;
encoded_data: array[.., ..] of AnsiChar;
row_height: array[..] of Integer; // Largest symbol is 189 x 189
errtxt: array[..] 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)
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=);
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 = ;
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_ := 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(, , FImage.Width, FImage.Height));
if AErrNumber= then
begin
ZBarcode_To_Bitmap;
FImage.Picture.Bitmap.Canvas.StretchDraw(Rect(, , FImage.Width - , FImage.Height - ), 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),);
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 * ; for Row := to Fsymbol.bitmap_height - do
begin
CopyMemory(FBitmap.ScanLine[Row], SrcRGB, RowWidth);
Inc(SrcRGB, Fsymbol.bitmap_width);
end; SetBitmapBits(FBitmap.Handle, Fsymbol.bitmap_width * Fsymbol.bitmap_height * , 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 :=;
FTimer.Enabled := False;
FTimer.OnTimer := CustomTimer;
FBitmap := TBitmap.Create;
FBitmap.PixelFormat := pf24bit;
FVideoImage := TVideoImage.Create;
FVideoImage.OnNewVideoFrame := NewVideoFrame;
FOffset := ;
end; procedure TZXingBarCode.CustomTimer(Sender: TObject);
var
pOri,pDesH,pDesV:TPoint;
begin
with FImage do
begin
Canvas.Pen.Color := clWebGreen;
Canvas.Pen.Width := ;
// Canvas.pen.Mode := pmXor; pOri := Point(,);
pDesH := Point(pOri.X+FOffset,pOri.Y);
pDesV := Point(pOri.X,pOri.Y+FOffset);
DrawLine(pOri,pDesH);
DrawLine(pOri,pDesV); pOri := Point(width-,);
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-,Height-);
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(,Height-);
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= then
raise Exception.Create('没有可用的摄像头.');
if FDefineDevice then
begin
if FDevices.IndexOf(FDeviceName)=- then
raise Exception.Create('传入的摄像头不存在!');
end else
begin
FDeviceName := FDevices[];//第一个摄像头
end;
finally
FDevices.Free;
end;
FScaning := FVideoImage.VideoStart(FDeviceName)=;//返回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=;
procedure TForm1.BitBtn1Click(Sender: TObject);
var
pOri,pDesH,pDesV:TPoint;
begin
with image1 do
begin
Canvas.Pen.Color := clGreen;
Canvas.Pen.Width := ;
Canvas.pen.Mode := pmXor; pOri := Point(,);
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-,);
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-,Height-);
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(,Height-);
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+));
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时会莫名的报错。
Delphi 二维码产生和扫描的更多相关文章
- wex5 实战 二维码生成，扫描，蓝牙打印
给人设计了一个小模块,要求是,把一个单号生成二维码,实现扫描查询单号具体信息,并能通过蓝牙把二维码打印出来.功能实现并不复杂,今天一口气把它搞定.来看效果. 一 效果演示: 二.二维码生成 1 在 ...
- 使用IOS7原生API进行二维码条形码的扫描
使用IOS7原生API进行二维码条形码的扫描 IOS7之前,开发者进行扫码编程时,一般会借助第三方库.常用的是ZBarSDK,IOS7之后,系统的AVMetadataObject类中,为我们提供了解析 ...
- Android开发——Android中的二维码生成与扫描
0. 前言 今天这篇文章主要描述二维码的生成与扫描,使用目前流行的Zxing,为什么要讲二维码,因为二维码太普遍了,随便一个Android APP都会有二维码扫描.本篇旨在帮助有需求的同学快速完成二维 ...
- Android项目实战（四十四）：Zxing二维码切换横屏扫描
原文:Android项目实战(四十四):Zxing二维码切换横屏扫描 Demo链接 默认是竖屏扫描,但是当我们在清单文件中配置横屏显示的时候: <activity android:name=&q ...
- Delphi 二维码生成
Delphi 二维码生成 http://download.csdn.net/detail/warrially/7370171
- （转： daifubing的博客 ）Delphi二维码中文支持、分组、批量打印经验小结
一直也没接触到什么复杂的报表,都是一些简单的报表,在DelphI下使用QuickReport一般也就能满足需要了,由于公司现在需求的变化,对条码扫描提出了新的要求,主要是扫码要包含更多地内容,以前的一 ...
- Android 基于google Zxing实现二维码、条形码扫描，仿微信二维码扫描效果
Android 高手进阶(21) 版权声明:本文为博主原创文章,未经博主允许不得转载. 转载请注明出处:http://blog.csdn.net/xiaanming/article/detail ...
- 【转】Android 基于google Zxing实现二维码、条形码扫描，仿微信二维码扫描效果--不错
原文网址:http://blog.csdn.net/xiaanming/article/details/10163203 转载请注明出处:http://blog.csdn.net/xiaanming/ ...
- iOS 之 二维码生成与扫描（LBXScan）
参考:https://github.com/MxABC/LBXScan 步骤如下: 1. 下载 通过参考网址进行下载. 2. 导入 导入整个LBXScan文件夹 3. 配置 在pch中加入 #impo ...
随机推荐
- java md5加密 不依赖base64包
/** * MD5 加密 */ private String getMD5Str(String str) { MessageDigest messageDigest = null; try { mes ...
- fs.watch 爬坑
上星期用 fs.watch 和 readline.createInterface 对pm2的合并日志做了监控,根据指定的错误信息重启服务 发现不管是手动vim编辑日志,还是等待日志自动输出. fs.w ...
- SDK登录cognos
通过SDK登录cognos 一种是拼xml,如这里的实现https://github.com/cosysoft/cognos-tools/blob/master/src/com/ibm/cognos/ ...
- 同源、同源策略、跨域问题、django解决方案
什么是同源: URL由协议.域名.端口和路径组成,如果两个URL的协议.域名和端口相同,则表示他们同源. 注意:假如你的网站ip是123.123.123.123,网站的域名是www.abc.com. ...
- happens-before规则
happens-before原则: happens-before它是判断数据是否存在竞争.线程是否安全的主要依据.为了保证线程安全我们可以让2个操作具有happens-before关系.(JDK5 开 ...
- LNMP的基本配置
LNMP的基本配置cd /usr/local/nginx_php/etc/ > php-fpm.conf //清空php-fpm.conf vim ph ...
- 超详细saltstack安装部署及应用
1.环境准备 准备两台虚拟机 主机名 ip role linux-node1 10.0.0.7 master linux-node2 10.0.0.8 minion 在节点1上安装 master 和 ...
- AC日记——摆花
思路: 矩阵加速dp: 代码: #include <cstdio> #include <cstring> #include <iostream> #include ...
- 好的web前端是如何拿到30万年薪的？
2018年前端开发不再像过去几年里新技术框架层出不穷,而是各种组件,模块,很多东西都有痕迹可寻,技术都在原来的基础上有了革新和沉淀. 前端招聘方面也在紧跟技术发展,大量“滥竽充数”的速成开发者开始失去 ...
- ASP.NET中怎样将页面设为首页,加入收藏
1.文字js脚本事件:<span onClick="var strHref=window.location.href;this.style.behavior=’url(#default ...