Motion Detection using VB6

Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias "capCreateCaptureWindowA" ( _
                ByVal lpszWindowName As String, _
                ByVal dwStyle As Long, _
                ByVal X As Long, ByVal Y As Long, _
                ByVal nWidth As Long, _
                ByVal nHeight As Long, _
                ByVal hWndParent As Long, _
                ByVal nID As Long) As Long
Private Declare Function DestroyWindow Lib "user32" ( _
                ByVal hWnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
                ByVal hWnd As Long, _
                ByVal wMsg As Long, _
                ByVal wParam As Long, _
                ByRef lParam As Any) As Long
               
Private Const WS_CHILD                  As Long = &H40000000
Private Const WS_VISIBLE                As Long = &H10000000
Private Const WM_USER                   As Long = &H400
Private Const WM_CAP_START              As Long = WM_USER
Private Const WM_CAP_DRIVER_CONNECT     As Long = WM_CAP_START + 10
Private Const WM_CAP_DRIVER_DISCONNECT  As Long = WM_CAP_START + 11
Private Const WM_CAP_FILE_SAVEDIB       As Long = WM_CAP_START + 25
Private Const WM_CAP_DLG_VIDEOFORMAT    As Long = WM_CAP_START + 41
Private Const WM_CAP_DLG_VIDEOSOURCE    As Long = WM_CAP_START + 42
Private Const WM_CAP_SET_PREVIEW        As Long = WM_CAP_START + 50
Private Const WM_CAP_SET_PREVIEWRATE    As Long = WM_CAP_START + 52
Private hCap                            As Long

'Private mCapHwnd As Long

Private Const CONNECT As Long = 1034
Private Const DISCONNECT As Long = 1035
Private Const GET_FRAME As Long = 1084
Private Const COPY As Long = 1054

         
'declarations
Dim P() As Long
Dim POn() As Boolean

Dim inten As Integer

Dim i As Integer, j As Integer

Dim Ri As Long, Wo As Long
Dim RealRi As Long

Dim c As Long, c2 As Long

Dim R As Integer, G As Integer, B As Integer
Dim R2 As Integer, G2 As Integer, B2 As Integer

Dim Tppx As Single, Tppy As Single
Dim Tolerance As Integer

Dim RealMov As Integer

Dim Counter As Integer

Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim LastTime As Long

Option Explicit

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Command2_Click()
    Call SendMessage(hCap, WM_CAP_DLG_VIDEOSOURCE, 0&, 0&)
End Sub

Private Sub Command3_Click()
    Call SendMessage(hCap, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
End Sub

Private Sub Form_Load()
'set up the visual stuff(Pixel)
Picture1.Width = 320 * Screen.TwipsPerPixelX
Picture1.Height = 240 * Screen.TwipsPerPixelY

Picture2.Width = 320 * Screen.TwipsPerPixelX
Picture2.Height = 240 * Screen.TwipsPerPixelY

Picture3.Width = 320 * Screen.TwipsPerPixelX
Picture3.Height = 240 * Screen.TwipsPerPixelY

Picture4.Width = 320 * Screen.TwipsPerPixelX
Picture4.Height = 240 * Screen.TwipsPerPixelY

'Inten is the measure of how many pixels are going to be recognized. I highly dont recommend
'setting it lower than this, i have a 3.0 GHz PC and it starts to lag a little. On this setting,
'every 15th pixel is checked
inten = 15
'The tolerance of recognizing the pixel change
Tolerance = 20

Tppx = Screen.TwipsPerPixelX
Tppy = Screen.TwipsPerPixelY

ReDim POn(640 / inten, 480 / inten)
ReDim P(640 / inten, 480 / inten)

End Sub



Private Sub Label1_Click()

End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
hCap = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Picture1.hWnd, 0)
    If hCap <> 0 Then
        Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
    End If
End Sub
Private Sub Picture2_Click()
hCap = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Picture2.hWnd, 0)
    If hCap <> 0 Then
        Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
    End If
End Sub

Private Sub Picture3_Click()
hCap = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Picture3.hWnd, 0)
    If hCap <> 0 Then
        Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
    End If
End Sub

Private Sub Picture4_Click()
hCap = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, 640, 480, Picture4.hWnd, 0)
    If hCap <> 0 Then
        Call SendMessage(hCap, WM_CAP_DRIVER_CONNECT, 0, 0)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEWRATE, 66, 0&)
        Call SendMessage(hCap, WM_CAP_SET_PREVIEW, CLng(True), 0&)
    End If
End Sub

Private Sub Timer1_Timer()
'Get the picture from camera.. the main part
SendMessage hCap, GET_FRAME, 0, 0
SendMessage hCap, COPY, 0, 0
Picture1.Picture = Clipboard.GetData
Clipboard.Clear

Ri = 0 'right
Wo = 0 'wrong

LastTime = GetTickCount

For i = 0 To 640 / inten - 1
    For j = 0 To 480 / inten - 1
    'get a point
    c = Picture1.Point(i * inten * Tppx, j * inten * Tppy)
    'analyze it, Red, Green, Blue
        R = c Mod 256
        G = (c \ 256) Mod 256
        B = (c \ 256 \ 256) Mod 256
        
    'recall what the point was one step before this
    c2 = P(i, j)
        'analyze it
        R2 = c2 Mod 256
        G2 = (c2 \ 256) Mod 256
        B2 = (c2 \ 256 \ 256) Mod 256
        
    'main comparison part... if each R, G and B are somewhat same, then it pixel is same still
    'in a perfect camera and software tolerance should theoretically be 1 but this isnt true...
    If Abs(R - R2) < Tolerance And Abs(G - G2) < Tolerance And Abs(B - B2) < Tolerance Then
    'pixel remained same
    Ri = Ri + 1
    'Pon stores a boolean if the pixel changed or didnt, to be used to detect REAL movement
    POn(i, j) = True
    
    Else
    'Pixel changed
    Wo = Wo + 1
    'make a red dor
    P(i, j) = Picture1.Point(i * inten * Tppx, j * inten * Tppy)
    Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbRed
    POn(i, j) = False
    End If
    
    Next j
    
Next i

RealRi = 0

For i = 1 To 640 / inten - 2
    For j = 1 To 480 / inten - 2
    If POn(i, j) = False Then
        'Real movement is simply occuring when all 4 pixels around one pixel changed
        'Simply put, If this pixel is changed and all around it changed too, then this is a real
        'movement
        If POn(i, j + 1) = False Then
            If POn(i, j - 1) = False Then
                If POn(i + 1, j) = False Then
                    If POn(i - 1, j) = False Then
                    RealRi = RealRi + 1
                    Picture1.PSet (i * inten * Tppx, j * inten * Tppy), vbGreen
                    End If
                End If
            End If
        End If
        
    End If
        
        
    Next j
Next i

'state all statistics(regarding movements etc @ blue box)
Label1.Caption = Int(Wo / (Ri + Wo) * 100) & " % movement" & vbCrLf & "Real Movement: " & RealRi & vbCrLf _
& "Completed in: " & GetTickCount - LastTime

End Sub


Sub STOPCAM()
DoEvents: SendMessage hCap, DISCONNECT, 0, 0
Timer1.Enabled = False
End Sub