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