New Motion detector component for Delphi 7 and XE

TMotionDetector
Motion detector component for Delphi 7 and XE

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 than can be read.
Optional 8-Bit mask of motion can be enabled, and drawn on the image if desired.
It has tolerance and minimum pixel difference tolerance that can be adjusted to exclude background noise and so on.

HISTORY

2012, July: Version 1.1 available at webpage
2012, April: Thanks to Soitjes for sending me his Delphi XE version of the project.
2012, February: Version 1.0 available at webpage

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

Download Motiondetect v1.1.zip, 215.36 Kb.

website pengembang : http://www.mortenbs.com

Properties

Property	Description
tolerance:cardinal	Tolerance (Number of pixels)
minimumDifference:byte	Minimum pixel-difference tolerance
useDetectLight:boolean	Enable lightness detection (slower)
motionMask:tShowMask	Show motion mask (None, Full Mask, Motion Only, Last Motion Only)
onMotion:tSimpleEvent	Event when motion above tolerance is beginning
value:cardinal	Current number of pixels above the tolerance
lightness:cardinal	Current lightness amount
hasMotion:boolean	Is true when motion and three seconds after
maxDiff:byte	Maximum difference that can be read as info

Routines

Routine	Description
reset	Reset motion info parameters
setSize()	Set width and height simultaneously
feedFrame():boolean	Feed frame into the motion detector
getImage():boolean	Get current image with overlays
sq:cardinal	Square size (width*height)

Motiondetect Src.pas (TMotionDetector)

unit motiondetect;

//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;
 //windows.beep(1000,100)
end;

//..

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

procedure Register;
begin
 registerComponents('Standard', [tMotionDetector]);
end;

end.

Motiondetect Demo.pas (TMotionDetector)

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.