Gallery
Software
Music
Programming
Archive
Wednesday, Jan 16 Week 3

The motion detector is used to detect motion and lightness from webcam, video frames and more... By feeding frames into the component, it defines the value and lightness parameters that can be read. Optional 8-Bit mask of motion can be enabled, and drawn on the image. It has sensivity and tolerance that can be adjusted to optimize performance and excluding background noise.


History

2013, November: Version 1.2
2012, July: Version 1.1
2012, February: Version 1.0

Updates

• Support of pixel-formats: 8-Bit, 16-Bit, 24-Bit and 32-Bit
• New property for "detectionSecs", length until motion end
• Cardinal data types changed to LongWord (32-Bit)
• Changed events so now having "OnMotionBegin" and "OnMotionEnd"
• Changed events to TNotifyEvent for having "sender" argument available
• Added "initialize" procedure to avoid motion detect from start
• Optimizations made for descendant components
• Delphi versions compatibility.
• Fixed issues on "ShowMask" property. Note: ShowMask only on 24-Bit and 32-Bit
• Other changes.

Supported Delphi-versions

• Borland Delphi 5
• Borland Delphi 6
• Borland Delphi 7
• Codegear Delphi 2007
• Embarcadero Delphi 2010
• Embarcadero Delphi XE
• Embarcadero Delphi XE2

Download

motiondetect-1-2.zip
(415.66 Kb)
, Downloads: 1.485

Properties

Property Description
sensivity:byte Sensivity (1..255)
tolerance:longWord Tolerance (Number of pixels)
detectLightness:boolean Enable lightness detection (slower)
showMask:TShowMask Show motion mask (None, Full Mask, Motion Only, Last Motion Only)
hasMotion:boolean Is true when motion and three seconds after
value:longWord Current number of pixels above the tolerance
lightness:longWord Current lightness amount
maxDiff:byte Maximum difference that can be read as info
onMotionBegin:TNotifyEvent Event when motion above tolerance begins
onMotionEnd:TNotifyEvent Event when motion above tolerance ends

Routines

Routine Description
reset Reset stats
setSize() Set width and height simultaneously
initialize() Call this function first, to avoid motion from start
feedFrame():boolean Feed frame into the motion detector
getImage():boolean Get current image with overlays

{ *********************************************************************** }
{ Motion Detector v1.2, for TBitmap, updated November 2013 }
{ 2012-2013 http://www.mortenbs.com/it/delphi/?component=tmotiondetector }
{ *********************************************************************** }
//[D5] [D6] [D7] [D2007] [D2010] [XE] [XE2]

//New:
// * Support of pixel-formats: 8-Bit, 16-Bit, 24-Bit and 32-Bit
// * New property for "detectionSecs", length until motion end
// * Cardinal data types changed to LongWord (32-Bit)
// * Changed events so now having "OnMotionBegin" and "OnMotionEnd"
// * Changed events to TNotifyEvent for having "sender" argument available
// * Added "initialize" procedure to avoid motion detect from start
// * Optimizations made for descendant components
// * Delphi versions compatibility.
// * Fixed issues on "ShowMask" property. Note: ShowMask only on 24-Bit and 32-Bit
// * Other changes...

unit motiondetect;

interface

uses
sysUtils,classes,graphics;

{$IFDEF VER130} //Delphi 5
type
pByte = ^byte;
{$ENDIF}

type
TShowMask=(
smNone, //No mask overlay
smFullMask, //Full mask (background becomes GREEN, and motion becomes RED)
smMotion, //Show motion (becomes RED)
smMotionNew //Show new motion compared to last interval
);

type
//--------------------------|---------------------|-----------------------|-------------------------<
TMotionDetect=class(TComponent) //Custom motion detector for descendants
procedure reset; //Reset stats
procedure setSize(w,h:word);virtual; //Set width and height simultaneously
private
res :byte;
endTick :int64;
lh,vl :longWord;
init :boolean;
fOnMotionBegin :TNotifyEvent;
fOnMotionEnd :TNotifyEvent;
procedure setTolerance(n:longWord);
procedure setSensivity(b:byte);
procedure setDetectionSecs(n:byte);
procedure setPixelFormat(pf:TPixelFormat);
protected
fDetectionSecs :byte; //Motion detection length (trigger)
pLastFrame :pByte; //Last frame data to compare (24-Bit)
pMotionMask :pByte; //Optional motion mask overlay (8-Bit)
fWidth,fHeight :word; //Size
fTolerance :longWord; //Tolerance of different pixels
fSensivity :byte; //Minimum pixel difference
fShowMask :TShowMask; //Motion mask overlay
fDetectLightness :boolean; //Enable using lightness count
fPixelFormat :TPixelFormat; //Pixel format [8-Bit,24-Bit,32-Bit]
procedure motionBegin;virtual;
procedure motionEnd;virtual;
procedure motionProc(p:pByte;sz:longWord;var mP,lP:pByte);virtual;
public
hasMotion :boolean; //stats: Is there currently motion
maxDiff :byte; //stats: Current max difference of any pixel
value :longWord; //stats: Current motion [0..sq]
lightness :byte; //stats: Current lightness amount [00..FF]
constructor Create(AOwner:TComponent);override;
destructor Destroy;override;
published
property detectionSecs :byte read fDetectionSecs write setDetectionSecs;
property detectLightness :boolean read fDetectLightness write fDetectLightness;
property sensivity :byte read fSensivity write setSensivity;
property showMask :TShowMask read fShowMask write fShowMask;
property pixelFormat :TPixelFormat read fPixelFormat write setPixelFormat;
property tolerance :longWord read fTolerance write setTolerance;
property width :word read fWidth; //readonly
property height :word read fHeight; //readonly
property onMotionBegin :TNotifyEvent read fOnMotionBegin write fOnMotionBegin;
property onMotionEnd :TNotifyEvent read fOnMotionEnd write fOnMotionEnd;
end;
//--------------------------|---------------------|-----------------------|-------------------------<

type
TMotionEventBmp=procedure(bmp:TBitmap) of object;
//--------------------------|---------------------|-----------------------|-------------------------<
TMotionDetect_bmp=class(TMotionDetect) //Motion detector for TBitmap 24-Bit
procedure initialize(bmp:TBitmap);//Call this function first, to avoid motion detect from start
function feedFrame(bmp:TBitmap):boolean;virtual;//Feed frame into the motion detector
function getImage(bmp:TBitmap;rePaint:boolean=true):boolean;virtual;//Get current image with overlays
protected
fOnFeedFrame :TMotionEventBmp;
fOnGetImage :TMotionEventBmp;
published
property onFeedFrame :TMotionEventBmp read fOnFeedFrame write fOnFeedFrame;
property onGetImage :TMotionEventBmp read fOnGetImage write fOnGetImage;
end;
//--------------------------|---------------------|-----------------------|-------------------------<

type
TMotionDetector=TMotionDetect_bmp; //Registered TMotionDetector component for bitmap

const
TPixelFormats=[pf8bit,pf16bit,pf24bit,pf32bit]; //Supported pixel-formats

function tick64:int64;stdcall; //Get tick count (64-Bit)
//--
procedure Register;

implementation

type
pRgb=^TRgb;
TRgb=record b,g,r:byte end; //RGB, 24-Bit

const
NULL = #0; //Blank ANSI-char value

procedure pFill(p:pAnsiChar;sz:longWord;ch:ansiChar=NULL);
var eP:pAnsiChar;
begin
eP:=p+sz;
while p<>eP do begin p^:=ch;inc(p) end;
end;

//"safe" reallocate + fill blank
function pReAlloc(var p;sz:longWord;aZeroMem:boolean=true):boolean;
begin
try reAllocMem(pointer(p),sz);result:=true except result:=false end;
if result and aZeroMem then pFill(pointer(p),sz,NULL);
end;

function between(i,min,max:int64):int64;
begin
if i<min then result:=min else
if i>max then result:=max else
result:=i;
end;

function max(n,max:word):word;
begin
if n<=max then result:=n else result:=max;
end;

function tick64:int64;
external 'winmm.dll' name 'timeGetTime';

//--------------------------------------------------------------------------------------------------
//TMotionDetect:

constructor TMotionDetect.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
pLastFrame := nil;
pMotionMask := nil;
fWidth := 0;
fHeight := 0;
fDetectionSecs := 3;
fTolerance := 1000;
fSensivity := $20;
fShowMask := smMotion;
fDetectLightness := true;
setPixelFormat(pf24bit);
end;

destructor TMotionDetect.Destroy;
begin
dispose(pMotionMask);pMotionMask:=nil;
dispose(pLastFrame);pLastFrame:=nil;
inherited Destroy;
end;

procedure TMotionDetect.reset;
begin
hasMotion := false;
value := 0;
lightness := 0;
maxDiff := 0;
end;

procedure TMotionDetect.setSize(w,h:word);//Set width and height simultaneously
begin
reset;
fWidth:=w;
fHeight:=h;
if not pReAlloc(pMotionMask,w*h) then pMotionMask:=nil;
if not pReAlloc(pLastFrame,w*h*res) then pLastFrame:=nil;
end;

//Main routine for motion (supporting various graphic formats)
procedure TMotionDetect.motionProc(p:pByte;sz:longWord;var mP,lP:pByte);
var c,k,n:byte;eP:pAnsiChar;
begin
eP:=sz*res+pAnsiChar(p); //last pixel
while p<eP do begin k:=0; //loop pixels
for c:=1 to res do begin //loop bytes of pixel [1..4]
n:=abs(lP^-p^);lP^:=p^; //calc pixel difference
if n>k then k:=n; //keep largest difference
if fDetectLightness then inc(lh,p^); //detect lightness
inc(lP);inc(p); //next byte
end;
if k>maxDiff then maxDiff:=k; //detect maximum difference
if k>=fSensivity then inc(vl); //value by tolerance
if mP=nil then continue; //update motion mask
if (fShowMask=smMotionNew) and (k>=fSensivity) and (mP^>=fSensivity) then mP^:=0 else mP^:=k;
inc(mP);
end;
end;

procedure TMotionDetect.setTolerance(n:longWord);
begin
fTolerance:=between(n,10,MAXINT);
end;

procedure TMotionDetect.setSensivity(b:byte);
begin
fSensivity:=between(b,1,$FF);
end;

procedure TMotionDetect.setDetectionSecs(n:byte);
begin
fDetectionSecs:=between(n,1,5);
end;

procedure TMotionDetect.setPixelFormat(pf:TPixelFormat);
begin
if not (pf in TPixelFormats) then pf:=pf24bit;
fPixelFormat:=pf;
case pf of
pf8bit :res:=1;
pf16bit :res:=2;
pf24bit :res:=3;
pf32bit :res:=4;
end;
setSize(fWidth,fHeight); //update allocated sizes
end;

procedure TMotionDetect.motionBegin;
begin
if hasMotion or init then exit;
hasMotion:=true;
endTick:=fDetectionSecs*1000+tick64;
if assigned(fOnMotionBegin) then fOnMotionBegin(self);
end;

procedure TMotionDetect.motionEnd;
begin
if not hasMotion then exit;
hasMotion:=false;
if assigned(fOnMotionEnd) then fOnMotionEnd(self);
end;

//--------------------------------------------------------------------------------------------------
//TMotionDetect_bmp:

procedure TMotionDetect_bmp.initialize(bmp:TBitmap);
begin
init:=true;
feedFrame(bmp);
init:=false;
reset;
end;

function TMotionDetect_bmp.feedFrame(bmp:TBitmap):boolean;//Feed frame into the motion detector
var p:pByte;mP,lP:pByte;y:word;l:longWord;
begin
result:=false;
if (fWidth<>bmp.width) or (fHeight<>bmp.height) then setSize(bmp.width,bmp.height);
if bmp.pixelFormat<>fPixelFormat then exit; //bad pixelformat
if (fHeight<2) or (fWidth<2) then exit; //picture too small
p:=bmp.scanLine[0]; //first pixel (source)
l:=bmp.scanLine[1]-pAnsiChar(p); //per line
if fShowMask<>smNone then mP:=pMotionMask else mP:=nil; //motion mask (if enabled)
lP:=pLastFrame;maxDiff:=0;vl:=0;lh:=0; //reset

for y:=0 to fHeight-1 do begin //loop lines
motionProc(p,fWidth,mP,lP); //motion procedure
inc(p,l); //next source line
end;

value:=vl; //New motion value
lightness:=lh div (fWidth*fHeight*res); //New lightness value [00..FF]
result:=true; //Success
if (not hasMotion) and (value>=tolerance) then motionBegin;
if hasMotion and (value<tolerance) and (tick64>endTick) then motionEnd;
if assigned(fOnFeedFrame) then fOnFeedFrame(bmp);
end;

function TMotionDetect_bmp.getImage(bmp:TBitmap;rePaint:boolean=true):boolean;//Get current image with overlays
var c:byte;y:word;p,dP,lP,mP:pByte;eP:pAnsiChar;k,l:longWord;
begin
result:=false;
if (fHeight<2) or (fWidth<2) or (pLastFrame=nil) then exit; //exit if empty picture
bmp.pixelFormat:=fPixelFormat; //same pixelformat
bmp.height:=fHeight;
bmp.width:=fWidth;
p:=bmp.scanLine[0]; //first pixel
l:=bmp.scanLine[1]-pAnsiChar(p); //per line
k:=fWidth*res; //bytes per line
lP:=pLastFrame; //last frame (current)
if fShowMask<>smNone then mP:=pMotionMask else mP:=nil; //motion mask
for y:=0 to fHeight-1 do begin //loop lines
dP:=p;eP:=pAnsiChar(p)+k; //start+end pointer
while dP<eP do begin //loop pixels of line
if (mP<>nil) and (res in [3,4]) then with pRgb(dP)^ do begin
if mP^>fSensivity then begin r:=max(r+mP^,$FF);g:=0;b:=0 end else
if fShowMask=smFullMask then begin r:=0;g:=max(g+mP^,$FF);b:=0 end;
inc(mP);
end;
if not repaint then inc(dP,res) else
for c:=1 to res do begin dP^:=lP^;inc(lP);inc(dP) end;
end;inc(p,l);
end;
result:=true;
if assigned(fOnGetImage) then fOnGetImage(bmp);
end;

//..

const
COMPONENT_PAGE = 'mortenbs.com';

procedure Register;
begin
registerComponents(COMPONENT_PAGE, [TMotionDetect]);
end;

end.

unit Unit1;

interface

uses
windows,sysUtils,classes,controls,graphics,forms,comObj,activeX,
directShow9,motiondetect, StdCtrls, ExtCtrls;

type
TForm1 = class(TForm)
Panel1: TPanel;
Image1: TImage;
Timer1: TTimer;
cmDetectLight: TCheckBox;
drpPixelFormat: TComboBox;
Label1: TLabel;
Label2: TLabel;
drpMaskOverlay: TComboBox;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
lbVidSize: TLabel;
Label7: TLabel;
lbTotPixels: TLabel;
Label9: TLabel;
lbCpuTime: TLabel;
drpUpdateRate: TComboBox;
Label6: TLabel;
cmTextOverlay: TCheckBox;
cmBeep: TCheckBox;
Label8: TLabel;
drpTolerance: TComboBox;
Label10: TLabel;
drpSensivity: TComboBox;
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure motionBegin(Sender: TObject);
procedure motionEnd(Sender: TObject);
procedure motionGetImage(bmp:TBitmap);
procedure updateChanges(Sender: TObject);
procedure FormShow(Sender: TObject);
private
pGraph :iGraphBuilder;
pBuilder :iCaptureGraphBuilder2;
pDevEnum :iCreateDevEnum;
pClassEnum :iEnumMoniker;
pMoniker :iMoniker;
pSrc :iBaseFilter;
videoWindow :iVideoWindow;
mediaControl :iMediaControl;
cameraStarted :boolean;
processingTime :word;
public
motion :TMotionDetector;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
var i:longInt;
begin
doubleBuffered:=true;
cameraStarted:=false;

motion:=TMotionDetector.Create(nil);
motion.onMotionBegin := motionBegin;
motion.onMotionEnd := motionEnd;
motion.onGetImage := motionGetImage;

image1.picture.bitmap:=TBitmap.Create;
with image1.picture.bitmap do begin
pixelFormat:=pf24bit;
width:=image1.width;
height:=image1.height;
end;

try
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,@i)=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;
cameraStarted:=true;
except
caption:='Error. ';
end;

end;

procedure TForm1.FormShow(Sender: TObject);
begin
application.title:=caption;

drpPixelFormat.itemIndex:=2;
drpMaskOverlay.itemIndex:=2;
drpUpdateRate.itemIndex:=0;
drpTolerance.itemIndex:=7;
drpSensivity.itemIndex:=3;

updateChanges(nil);
end;

var
firstTime :boolean = true; //Used to avoid motion from start
startDelay :byte = 2; //Wait for camera focus and light...

procedure TForm1.Timer1Timer(Sender: TObject);
var bmp:TBitmap;dc:hdc;v:int64;
begin
if not cameraStarted then exit;
if startDelay<>0 then begin dec(startDelay);exit end;

v:=tick64;
bmp:=TBitmap.Create;
dc:=getDc(panel1.handle);
bmp.pixelFormat:=motion.pixelFormat;
bmp.width:=image1.width;
bmp.height:=image1.height;
bitblt(bmp.canvas.handle,0,0,width,height,dc,0,0,SRCCOPY);

if firstTime then begin
motion.initialize(bmp);
firstTime:=false;
end else begin
motion.feedFrame(bmp);
motion.getImage(bmp,false);
end;

image1.picture.bitmap.canvas.draw(0,0,bmp);
bmp.free;
processingTime:=tick64-v;

//stats
lbVidSize.caption:=intToStr(motion.width)+'x'+intToStr(motion.height)+' px.';
lbTotPixels.caption:=intToStr(motion.width*motion.height);
lbCpuTime.caption:=intToStr(processingTime)+' ms.';
end;

procedure TForm1.motionGetImage(bmp:TBitmap);
var sq:longWord;
begin
if cmTextOverlay.checked then //some text overlay...
with motion,bmp,canvas do begin
sq:=width*height;
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)+' of '+intToStr($FF));
textOut(5,35,'Max difference: '+intToStr(maxDiff));
end;
end;

procedure TForm1.motionBegin(Sender: TObject);
begin
if cmBeep.checked then windows.beep(880,100);
end;

procedure TForm1.motionEnd(Sender: TObject);
begin
if cmBeep.checked then windows.beep(440,100);
end;

procedure TForm1.updateChanges(Sender: TObject);
begin
timer1.interval:=250*(drpUpdateRate.ItemIndex+1);
motion.detectLightness:=cmDetectLight.checked;
motion.showMask:=TShowMask(drpMaskOverlay.itemIndex);
motion.tolerance:=1000*(drpTolerance.itemIndex+1);
motion.sensivity:=strToInt(drpSensivity.items.strings[drpSensivity.itemIndex]);

case drpPixelFormat.itemIndex of
0:motion.pixelFormat:=pf8bit;
1:motion.pixelFormat:=pf16bit;
2:motion.pixelFormat:=pf24bit;
3:motion.pixelFormat:=pf32bit;
end;

drpMaskOverlay.enabled:=motion.pixelFormat in [pf24bit,pf32bit];

end;

end.



Related pages of TMotionDetector component

Surveillance Camera 1.0
Programming
Software
Delphi programming