' ' ------------------------------------------------------------------------------------ ' MOTION DETECTION WITH A WEBCAM December 7th, 2005 by Jacques ' ' Uses AviCap32.Dll functions and an assembler function to compare two successive ' grabbed Bitmaps (included) ' ------------------------------------------------------------------------------------ ' $ESCAPECHARS ON $TYPECHECK ON $INCLUDE "RapidQ.Inc" ' Const WS_VISIBLE = &H10000000 Const WS_CHILD = &H40000000 ' Const WM_CAPFIRST = 1024 Const WM_CAP_DRIVER_CONNECT = WM_CAPFIRST + 10 Const WM_CAP_DRIVER_DISCONNECT = WM_CAPFIRST + 11 Const WM_CAP_FILE_SAVEDIB = WM_CAPFIRST + 25 Const WM_CAP_SET_SCALE = WM_CAPFIRST + 53 Const WM_CAP_GRAB_FRAME = WM_CAPFIRST + 60 Const WM_CAP_DLG_VIDEOFORMAT = WM_CAPFIRST + 41 Const WM_CAP_DLG_VIDEOSOURCE = WM_CAPFIRST + 42 ' Const HWND_TOP = 0 Const SWP_NOACTIVATE = &H10 Const SWP_SHOWWINDOW = &H40 ' Declare Function CallAsmProc LIB "user32" Alias "CallWindowProcA" (Proc AS Long, A1 AS Long, _ A2 AS Long, A3 AS Long, A4 AS Long) AS Long Declare Function SendMessageX Lib "user32" Alias "SendMessageA" (hWnd As Long, wMsg As Long, _ wParam As Long, lParam As Long) As Long Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" _ (lpszWindowName As String, dwStyle As Long, left As Long, top As Long, nWidth As Long, _ nHeight As Long, hwndParent As Long, nID As Long) As Long Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" (hwnd As Long, hWndInsertAfter As Long, _ x As Long, y As Long, cx As Long, cy As Long, wFlags As Long) As Long Declare Function Beep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long ' Declare Sub OnClose_frmDetectMotion Declare Sub OnClic_btnStart Declare Function CreateViewWindow () As Long Declare Sub OnTimer_tmrSpy Declare Sub OnfrmDetectMotion_KeyPress (key As Byte) Declare Function GetOneFrame () As String Declare Sub OnClic_AnyMenu (Sender As QMenuItem) ' Create frmDetectMotion As QForm Center Width = 680 height = 750 Color = &HC13F00 Caption = "frmDetectMotion" KeyPreview = True BorderStyle = bsSingle AutoScroll = False OnKeyPress = OnfrmDetectMotion_KeyPress OnClose = OnClose_frmDetectMotion Create pnlBottom As QPanel Height = 35 Align = alBottom Font.Name = "courier" Font.Size = 16 Create lblThreshold As QLabel Align = alLeft Color = &HD7F2F0 AutoSize = True Caption = " THRESHOLD: 2.5 pc (+/- change)" End Create Create btnStart AS QButton Align = alClient Font.Color = &H1E1EFF Font.Bold = True Caption = "&START" OnClick = OnClic_btnStart End Create End Create Create rchWin AS QRichEdit Height = 150 Align = alTop Font.Name = "courier" Font.Size = 12 color = &HFAFFFF Font.Color = &H000040 ReadOnly = True WordWrap = False ScrollBars = ssBoth HideSelection = False PlainText = True Text = "\n JUST PLUG A CAM IN and CLICK ON \"START\"" _ & "\n\n Then adjust Threshold with Key '+' and '-'" End Create Create mnuMain AS QMAINMENU Create mnuVideoSetup AS QMENUITEM Caption = "&CONFIG CAM" Create mnuFormatDlg AS QMENUITEM Caption = "&VIDEO FORMAT (Size)" OnClick = OnClic_AnyMenu End Create Create mnuSourceDlg AS QMENUITEM Caption = "&VIDEO SOURCE (Brightness, Contrast, ...)" OnClick = OnClic_AnyMenu End Create End Create End Create End Create ' ==================================================================================== ' ----- ARRAY containing ASM GetBMPDifference ----- DefByte GetBMPDifferenceArray (0 To 88) = _ {&H55,&H89,&HE5,&H8B,&H75,&H08,&H8B,&H7D,&H0C,&H8B,&H46,&H0A,&H8B,&H4F,&H0A,&H39, _ &HC8,&H74,&H0A,&HB8,&H01,&H00,&H00,&H00,&HE9,&H36,&H00,&H00,&H00,&HFC,&H41,&H49, _ &H74,&H0D,&HA6,&H74,&HFA,&HB8,&H02,&H00,&H00,&H00,&HE9,&H24,&H00,&H00,&H00,&H31, _ &HC0,&H8B,&H75,&H08,&H8B,&H4E,&H22,&H03,&H76,&H0A,&H8B,&H7D,&H0C,&H03,&H7F,&H0A, _ &H31,&HDB,&H8A,&H1E,&H8A,&H17,&H28,&HD3,&H73,&H02,&HF6,&HDB,&H01,&HD8,&H46,&H47, _ &H49,&H75,&HEF,&H89,&HEC,&H5D,&HC2,&H10,&H00} ' ----- POINTER to use In CallAsmProc ----- DefInt ptrGetBMPDifference = VarPtr (GetBMPDifferenceArray(0)) ' ----- RQ CALL GetBMPDifference ----- Function GetBMPDifference (ptrPic_1 As Long, ptrPic_2 As Long) As Long Result = CallAsmProc (ptrGetBMPDifference, ptrPic_1, ptrPic_2, 0, 0) End Function ' ==================================================================================== ' GLOBAL DATAS ' ------------ DefInt hCamWnd DefStr CamTitle = "CaptureWindow" DefInt iDevice = 0 ' 0 to 9 Dim tmrSpy As QTimer tmrSpy.Enabled = False tmrSpy.Interval = 1000 ' time between two pictures tmrSpy.OnTimer = OnTimer_tmrSpy DefInt flagPic1or2, flagStarted = False DefStr Bmp1 = "Pic1.Bmp", Bmp2 = "Pic2.Bmp" DefStr strBmp1, strBmp2 DefInt iFrameCount = 0 DefInt iLastDiff = 0 Defint iThreshold = 25 DefInt flagMenuBusy = False ' ************************************* frmDetectMotion.ShowModal ' ************************************* ' Sub OnClose_frmDetectMotion SendMessageX (hCamWnd, WM_CAP_DRIVER_DISCONNECT, Camtitle, 0) Application.Terminate End Sub ' Function GetOneFrame () As String DefInt iGrabed = SendMessageX (hCamWnd, WM_CAP_GRAB_FRAME, 0, 0), iSaved Dim fileBmp As QFileStream DefStr sBmpFileName If iFrameCount Mod 2 = 1 Then sBmpFileName = Bmp1 Else sBmpFileName = Bmp2 End If iSaved = SendMessageX (hCamWnd, WM_CAP_FILE_SAVEDIB, 0, VarPtr(sBmpFileName)) fileBmp.Open (sBmpFileName, fmOpenRead) If iFrameCount Mod 2 = 1 Then strBmp1 = fileBmp.ReadBinStr (fileBmp.Size) Else strBmp2 = fileBmp.ReadBinStr (fileBmp.Size) End If fileBmp.Close Result = (" Frame=" & Str$(iFrameCount) & " Grab=" & Str$(iGrabed) & " Save=" & Str$(iSaved)) Inc iFrameCount End Function Sub OnClic_btnStart DefStr sTmp If flagStarted = True Then Exit Sub With frmDetectMotion hCamWnd = capCreateCaptureWindow(CamTitle, ws_child + ws_visible, 0, 210, _ 4*(.ClientHeight-250)/3, .ClientHeight-250, .Handle, 0) SetWindowPos (hCamWnd, HWND_TOP, (.ClientWidth - 640)/2 , rchWin.Top + rchWin.Height + _ (.ClientHeight - 480 - rchWin.Top - rchWin.height - pnlBottom.Height)/2, 640, _ 480, SWP_NOACTIVATE Or SWP_SHOWWINDOW) End With If hCamWnd <> 0 then rchWin.Addstring ("\n - OK : Cam Opened") flagStarted = True Else rchWin.Addstring ("\n - ERROR : Cannot Opened Cam") flagStarted = 0 Exit Sub End If If hCamWnd = 0 Then ShowMessage ("You must Open Cam First"):Exit Sub rchWin.Addstring (" CONNECT = " & Str$(SendMessageX (hCamWnd, WM_CAP_DRIVER_CONNECT, iDevice, 0)) & " Device: " & Str$(iDevice)) rchWin.Addstring (" SET SCALABLE = " & Str$(SendMessageX (hCamWnd, WM_CAP_SET_SCALE, True, 0))) ' init pictures and iDiffLast rchWin.Addstring GetOneFrame sTmp = GetOneFrame iLastDiff = GetBmpDifference (VarPtr(strBmp1), VarPtr(strBmp2)) rchWin.Addstring ("Diff=" & Str$(iLastDiff) & " " & sTmp) tmrSpy.Enabled = True End Sub ' Sub OnTimer_tmrSpy DefStr sTmp = GetOneFrame, sBeep = "" DefSng sngStartChrono = Timer DefInt iDiff = GetBmpDifference (VarPtr(strBmp1), VarPtr(strBmp2)) DefInt iDuration = Abs(1000 * (Timer - sngStartChrono)) DefSng sngThreshold = iThreshold/1000 If (iDiff > iLastDiff * (1 + sngThreshold) Or iDiff < iLastDiff * (1 - sngThreshold)) Then Sound (1000, 8):Beep(1000, 300) ' for W9X and XP sBeep = " BEEP" End If rchWin.Addstring ("Diff=" & Str$(iDiff) & sBeep & " Tcmp=" & Str$(iDuration) & "ms " & sTmp) iLastDiff = iDiff End sub ' Sub OnfrmDetectMotion_KeyPress (key As Byte) DefDbl dblThresh If (key = 43 or key = 45) Then If key = 43 Then Inc iThreshold If key = 45 Then Dec iThreshold If iThreshold < 0 Then iThreshold = 0 dblThresh = iThreshold/10 lblThreshold.Caption = " THRESHOLD : " & Str$(dblThresh) & " pc (+/- change)" End If End Sub ' Sub OnClic_AnyMenu (Sender) If flagMenuBusy = True Then Exit Sub flagMenuBusy = true Select Case Sender.Handle Case mnuFormatDlg.Handle If hCamWnd = 0 Then rchWin.Addstring (" *** ERROR *** : CAM MUST BE OPENED TO SET VIDEO FORMAT"):Exit Sub tmrSpy.Enabled = False rchWin.Addstring ("VIDEO FORMAT DIALOG = " & Str$(SendMessageX (hCamWnd, WM_CAP_DLG_VIDEOFORMAT, 0, 0)) & " (If 0, You Have None)") tmrSpy.Enabled = True Case mnuSourceDlg.Handle If hCamWnd = 0 Then rchWin.Addstring (" *** ERROR *** : CAM MUST BE OPENED TO SET VIDEO SOURCE"):Exit Sub tmrSpy.Enabled = False rchWin.Addstring ("VIDEO FORMAT SOURCE = " & Str$(SendMessageX (hCamWnd, WM_CAP_DLG_VIDEOSOURCE, 0, 0)) & " (If 0, You Have None)") tmrSpy.Enabled = True End select flagMenuBusy = False End Sub ' ------------------------------------------------------------------------------------ '; ---- RQASM/NASM code ---- '; SubPictures (USES THE BITMAP FILE FORMAT, Not The BitMap Memory Format) '; '; First check if the 54 Bytes of Headers are the same '; '; Result = 0 '; For N = 1 To Picture_Datas_Size '; Result = Result + Abs(Byte_1(N) - Byte_2(N)) '; Next N '; '; ptrPic_1 : Pointer to the first byte of the picture N°1 '; ptrPic_2 : Pointer to the first byte of the picture N°2 '; 'Function SubPictures ptrPic_1 ptrPic_2 '; Check both BMP file have same Header Size : dword (ptr + 10) ' mov esi, ptrPic_1 ' mov edi, ptrPic_2 ' mov eax, [esi+10] ' mov ecx, [edi+10] ' cmp eax, ecx ' jz .SameHeaderSize_OK ' mov eax, 1 ; 1 = ERROR NOT THE SAME HEADER SIZE, I ABORT ' jmp .Finished ' .SameHeaderSize_OK: '; Both BMP file header must be the same ' cld ' Inc ecx ' .LoopCompareHeader: ' dec ecx ' jz .HeaderCompare_OK ' cmpsb ' jz .LoopCompareHeader ' mov eax, 2 ; 2 = ERROR THE HEADERS ARE DIFFERENT ' jmp .Finished ' .HeaderCompare_OK: '; Substarct the files Byte by Byte, result in eax ' xor eax, eax ' mov esi, ptrPic_1 ' mov ecx, [esi+34] ; Image_Datas_Size In BMP At [ptr+34] ' add esi, [esi+10] ' mov edi, ptrPic_2 ' add edi, [edi+10] ' xor ebx, ebx '; ' .LoopSubColors: ' mov bl, [esi] ' mov dl, [edi] ' sub bl, dl ' jnc .Sub_OK ' neg bl ' .Sub_OK: ' add eax, ebx ' inc esi ' inc edi ' dec ecx ' jnz .LoopSubColors '; ' .Finished: 'End Sub '; ---- END RQASM/NASM CODE ' ------------------------------------------------------------------------------------ '