Kod: Tümünü seç
http://www.delphiturkiye.com/forum/viewtopic.php?f=2&t=25129#p142265 / http://www.delphiturkiye.com/forum/download/file.php?id=86
Kod: Tümünü seç
unit motiondetect;
//Motion Detector v1.1, 2012-07-05, mortenbs.com
//For Delphi 7 and XE, 24-Bit TBitmap
//HISTORY
//2012, July: Version 1.1 available at webpage: http://www.mortenbs.com/it/delphi/motiondetector/
//2012, April: Thanks to Soitjes sending me his Delphi XE version of the project.
//2012, February: Version 1.0 available at webpage: http://www.mortenbs.com/it/delphi/motiondetector/
//WHAT'S NEW
// * Changes of data types for Delphi version compatibility, pAnsiChar etc.
// * Lightness "div 3" not inside the loop, now done finally
// * Using pRgb directly, might be a little faster
interface
uses
sysUtils,classes,graphics;
type
pRgb=^tRgb;
tRgb=record b,g,r:byte end;//24-Bit RGB
const
NULL = #0;
NONE = $00;
type
tSimpleEvent=procedure of object;//Simple event without any arguments
tShowMask=(smNone,smFullMask,smMotionOnly,smLastMotionOnly);
//-----------------------------|----------------|----------------------|----------------------------
tMotionDetector=class(TComponent)//24-Bit bitmap motion detector
procedure reset; //Reset motion stats
procedure setSize(w,h:word); //Set width and height simultaneously
function feedFrame(aBmp:tBitmap):boolean; //Feed frame into the motion detector
function getImage(aBmp:tBitmap;aRePaint:boolean=true):boolean;//Get current image with addons
function sq:cardinal; //Square size of current width and height
procedure setTolerance(n:cardinal);
procedure setMinDiff(b:byte);
private
pLastFrame :pByte; //Last frame data to compare (24-Bit)
pMotionMask :pByte; //Optional motion mask overlay (8-Bit)
fWidth,fHeight :word; //Size
fTolerance :cardinal; //Tolerance of different pixels
fMinDiff :byte; //Minimum pixel difference
fMotionMask :tShowMask; //Motion mask overlay
fUseDetectLight :boolean; //Enable using lightness count
fOnMotion :tSimpleEvent; //..
motionTick :int64;
procedure notifyMotion;
public
//output stats:
hasMotion :boolean; //Is there motion currently
maxDiff :byte; //Current max difference of any pixel
value,lightness :cardinal; //Current motion and lightness amount
constructor create(aOwner:tComponent);override;
destructor destroy;override;
property tolerance :cardinal read fTolerance write setTolerance;
property minimumDifference :byte read fMinDiff write setMinDiff;
property useDetectLight :boolean read fUseDetectLight write fUseDetectLight;
property motionMask :tShowMask read fMotionMask write fMotionMask;
property onMotion :tSimpleEvent read fOnMotion write fOnMotion;
end;
//-----------------------------|----------------|----------------------|----------------------------
function tick64:int64;stdcall; //Get tick count (64-Bit)
//--
procedure Register;
implementation
procedure pFill(p:pAnsiChar;sz:cardinal;ch:ansiChar=NULL);
begin
while sz<>NONE do begin p^:=ch;inc(p);dec(sz) end;
end;
function pReAlloc(var p;aSize:cardinal;aZeroMem:boolean=true):boolean;
begin
try reAllocMem(pointer(p),aSize);result:=true except result:=false end;
if result and aZeroMem then pFill(pointer(p),aSize,NULL)
end;
//--------------------------------------------------------------------------------------------------
//tMotionDetector:
constructor tMotionDetector.create(aOwner:tComponent);
begin inherited create(aOwner);
pLastFrame:=nil;pMotionMask:=nil;
fWidth:=NONE;fHeight:=NONE;
fTolerance:=1000;fMinDiff:=35;
fMotionMask:=smMotionOnly;
fUseDetectLight:=true;
reset;
end;
destructor tMotionDetector.destroy;
begin
if pMotionMask<>nil then begin freeMem(pMotionMask);pMotionMask:=nil end;
if pLastFrame<>nil then begin freeMem(pLastFrame);pLastFrame:=nil end;
inherited destroy
end;
procedure tMotionDetector.reset;
begin hasMotion:=false;
value:=NONE;lightness:=NONE;maxDiff:=NONE;
end;
procedure tMotionDetector.setSize(w,h:word);//Set width and height simultaneously
begin
if (w=fWidth) and (h=fHeight) then exit;
fWidth:=w;fHeight:=h;reset;
if not pReAlloc(pMotionMask,sq) then exit; //"safe" reallocate and fill blank (clear)
if not pReAlloc(pLastFrame,sq*3) then exit; //"safe" reallocate and fill blank (clear)
end;
function tMotionDetector.feedFrame(aBmp:tBitmap):boolean;//Feed frame into the motion detector
var
p :pRgb;
eP,sP,pSrc :pAnsiChar;
mP,lP :pByte;
psl,v,l,z :cardinal;
k,n,aMaxDiff :byte;
y :word;
begin
result:=false;if aBmp.pixelFormat<>pf24bit then exit;
if (aBmp.height<>fHeight) or (aBmp.width<>fWidth) then setSize(aBmp.width,aBmp.height); //set size if different
if (fHeight<2) or (fWidth<2) then exit; //exit if empty picture
pSrc:=aBmp.scanLine[NONE];sP:=pSrc; //first pixel (source)
psl:=aBmp.scanLine[1]-pSrc; //bytes per scan line
if fMotionMask<>smNone then mP:=pMotionMask else mP:=nil; //motion mask (if enabled)
lP:=pLastFrame;aMaxDiff:=NONE;v:=NONE;l:=NONE;z:=fWidth*3; //reset
for y:=NONE to fHeight-1 do begin
p:=pRgb(sP);eP:=sP+z; //start + end pointer of current line (y)
while p<eP do begin //fast loop pixels
k:=abs(lP^-p^.b);lP^:=p^.b;inc(lP); //detect motion and write to last frame, BGR
n:=abs(lP^-p^.g);lP^:=p^.g;inc(lP);if n>k then k:=n;
n:=abs(lP^-p^.r);lP^:=p^.r;inc(lP);if n>k then k:=n;
if k>aMaxDiff then aMaxDiff:=k; //detect maximum difference
if k>=fMinDiff then inc(v); //value by tolerance
if fUseDetectLight then inc(l,p^.r+p^.g+p^.b); //detect lightness
inc(p);
if mP<>nil then begin //8-Bit mask of pixel difference
if fMotionMask<>smLastMotionOnly then mP^:=k else
if (mP^>fMinDiff) or (mP^=NONE) then mP^:=k else mP^:=NONE;
inc(mP);
end;
end;inc(sP,psl) //next source line
end;
value:=v;
if v>tolerance then begin
if not hasMotion then notifyMotion
end else
if hasMotion and (tick64-motionTick>=3000) then hasMotion:=false;
if fUseDetectLight then lightness:=l div 3;
maxDiff:=aMaxDiff;result:=true;
end;
function tMotionDetector.getImage(aBmp:tBitmap;aRePaint:boolean=true):boolean;//Get current image with addons
var
dP :pRgb;
eP,pDst :pAnsiChar;
lP,mP :pByte;
z,psl :cardinal;
i :smallInt;
y :word;
begin
result:=false;
aBmp.height:=fHeight;
aBmp.width:=fWidth;
aBmp.pixelFormat:=pf24bit;
if (fHeight<2) or (fWidth<2) or (pLastFrame=nil) then exit;//exit if empty picture
pDst:=aBmp.scanLine[NONE];//first pixel (dest)
psl:=aBmp.scanLine[1]-pAnsiChar(pDst);//bytes per scan line
lP:=pLastFrame;z:=fWidth*3;
if fMotionMask<>smNone then mP:=pMotionMask else mP:=nil;
for y:=NONE to fHeight-1 do begin
dP:=pRgb(pDst+y*psl);eP:=pAnsiChar(dP)+z;
while dP<eP do begin
if aRePaint then begin
dP^.b:=lP^;inc(lP);
dP^.g:=lP^;inc(lP);
dP^.r:=lP^;inc(lP)
end;//repaint frame
if mP<>nil then begin
case fMotionMask of
smMotionOnly,smLastMotionOnly:if mP^>fMinDiff then begin dP^.g:=NONE;dP^.b:=NONE;i:=dP^.r+mP^;if i>$FF then i:=$FF;dP^.r:=i end;
smFullMask:if mP^>fMinDiff then begin dP^.g:=NONE;dP^.b:=NONE;i:=dP^.r+mP^;if i>$FF then i:=$FF;dP^.r:=i end;
else
dP^.r:=NONE;
dP^.b:=NONE;
i:=dP^.g+mP^;if i>$FF then i:=$FF;
dP^.g:=i
end;
inc(mP);
end;inc(dP);
end;
end;
//some text overlay...
with aBmp.canvas do begin
brush.color:=clBlack;font.style:=[fsBold];
if hasMotion then font.color:=clRed else font.color:=clLime;
textOut(5,5,'Motion: '+intToStr(value)+' of '+intToStr(sq));
font.color:=clWhite;
textOut(5,20,'Lightness: '+intToStr(lightness div sq)+' of '+intToStr(255));
textOut(5,35,'Max difference: '+intToStr(maxDiff));
end;
result:=true
end;
function tMotionDetector.sq:cardinal;begin result:=fWidth*fHeight end;
procedure tMotionDetector.setTolerance(n:cardinal);begin if n<10 then n:=10;fTolerance:=n end;
procedure tMotionDetector.setMinDiff(b:byte);begin if b<1 then b:=1;fMinDiff:=b end;
procedure tMotionDetector.notifyMotion;
begin hasMotion:=true;motionTick:=tick64;
if assigned(fOnMotion) then fOnMotion;
//beep;
end;
//..
function tick64:int64;external'winmm.dll' name'timeGetTime';
procedure Register;
begin
registerComponents('Standard', [tMotionDetector]);
end;
end.
Kod: Tümünü seç
unit Unit1;
interface
uses
windows,sysUtils,classes,controls,graphics,forms,comObj, ExtCtrls, activeX,
directShow9, motiondetect;
type
TForm1 = class(TForm)
Panel1: TPanel;
Image1: TImage;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
pGraph :iGraphBuilder;
pBuilder :iCaptureGraphBuilder2;
pDevEnum :iCreateDevEnum;
pClassEnum :iEnumMoniker;
pMoniker :iMoniker;
pSrc :iBaseFilter;
cFetched :pLongInt;
videoWindow :iVideoWindow;
mediaControl :iMediaControl;
public
motion :tMotionDetector;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
motion:=tMotionDetector.create(nil);
image1.picture.bitmap:=tBitmap.create;
with image1.picture.bitmap do begin
pixelFormat:=pf24bit;
width:=image1.width;
height:=image1.height
end;
//--
pGraph:=createComObject(CLSID_FilterGraph) as iGraphBuilder;
pBuilder:=createComObject(CLSID_CaptureGraphBuilder2) as iCaptureGraphBuilder2;
pBuilder.SetFiltergraph(pGraph);
pDevEnum:=createComObject(CLSID_SystemDeviceEnum) as iCreateDevEnum;
pDevEnum.createClassEnumerator(CLSID_VideoInputDeviceCategory,pClassEnum,0);
if pClassEnum.next(1,pMoniker,cFetched)=S_OK then
pMoniker.bindToObject(nil,nil,IID_IBaseFilter,pSrc);
pGraph.addFilter(pSrc,'Video Capture');
pGraph.queryInterface(IID_IMediaControl,mediaControl);
pGraph.queryInterface(IID_IVideoWindow,videoWindow);
pBuilder.renderStream(@PIN_CATEGORY_PREVIEW,@MEDIATYPE_VIDEO,pSrc,nil,nil);
videoWindow.put_windowStyle(WS_CHILD or WS_CLIPSIBLINGS);
videoWindow.setWindowPosition(0,0,panel1.width,panel1.height);
videoWindow.put_owner(panel1.handle);
mediaControl.run;
timer1.interval:=250;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var aBmp:tBitmap;dc:hdc;
begin
aBmp:=tBitmap.create;dc:=getDc(panel1.handle);
with aBmp do begin pixelFormat:=pf24bit;width:=image1.width;height:=image1.height end;
bitblt(aBmp.canvas.handle,NONE,NONE,width,height,dc,NONE,NONE,SRCCOPY);
motion.feedFrame(aBmp);
motion.getImage(aBmp);
image1.picture.bitmap.canvas.draw(NONE,NONE,aBmp);
aBmp.free;
end;
end