Простой программный датчик движения для ВЕБ-камеры

Option Explicit
'
Private Type BITMAPINFOHEADER
    biSize As Long
    biWidth As Long
    biHeight As Long
    biPlanes As Integer
    biBitCount As Integer
    biCompression As Long
    biSizeImage As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed As Long
    biClrImportant As Long
End Type
'
Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
'
Private Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End Type
'
'Размер картинки (потока)
Private Type picSIZE
    Width As Long
    Height As Long
End Type
'
Dim Bt As BITMAPINFO
Private Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
'
Private Const WM_USER = 1024
Private Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_USER + 41
'
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds 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
'
''''''''''''''''''
Private Const WM_CAP_START = WM_USER
Private Const WM_CAP_GET_VIDEOFORMAT = WM_CAP_START + 44
Private Const WM_CAP_SET_VIDEOFORMAT = WM_CAP_START + 45
Private Const WM_CAP_DRIVER_CONNECT = WM_CAP_START + 10
''''''''''''''''''''''''''''''''''''
'
Dim FileParam As String
'
Dim tempFilename As String
Dim pZ() As picSIZE
Dim mZ As picSIZE   'Текущие размеры картинки
Dim xZ As picSIZE   '
'
Dim levelSENS As Long   'Уровень срабатывания датчика движения
'
 
Private Sub Check1_Click()
    If Check1.Value = 1 Then
        Timer2.Enabled = True
        Check1.Caption = "Stop REC"
    Else
        Check1.Caption = "Start REC"
        Timer2.Enabled = False
    End If
End Sub
 
Private Sub Check2_Click()
    Check2.Tag = 0
    If Check2.Value = 1 Then
        Timer3.Enabled = True
    Else
        Timer3.Enabled = False
    End If
End Sub
 
Private Sub Form_Load()
Dim i As Integer, j As Integer, chm As Integer, ff As Integer
    '
    Timer1.Enabled = True
    Timer1.Interval = 50
    Timer2.Enabled = False
    Timer2.Interval = 1000
    Timer3.Enabled = False
    Timer3.Interval = 250
    Timer4.Enabled = False
    Timer4.Interval = 100
    '
    Form1.ScaleMode = 3
    Form1.Width = 9900
    Form1.Height = 9500
    '
    Picture1(0).ScaleMode = 3
    Picture1(0).Left = 8
    Picture1(0).Top = 8
    Picture1(0).Width = 640
    Picture1(0).Height = 480
    Picture1(0).AutoRedraw = True
    Picture1(0).AutoSize = True
    '
    Command1.Left = 96
    Command1.Top = 528
    Command1.Width = 97
    Command1.Height = 33
    Command1.Caption = "Сделать снимок"
    '
    Command2.Left = 16
    Command2.Top = 528
    Command2.Width = 73
    Command2.Height = 33
    Command2.Caption = "Пуск"
    '
    Command3.Left = 16
    Command3.Top = 568
    Command3.Width = 73
    Command3.Height = 33
    Command3.Caption = "Close"
    '
    Command4.Left = 96
    Command4.Top = 528
    Command4.Width = 97
    Command4.Height = 33
    Command4.Caption = "Сделать снимок"
    '
    List1.Left = 200
    List1.Top = 528
    List1.Width = 65
    List1.Height = 69
    '
    Label1.Left = 600
    Label1.Top = 544
    Label1.Width = 31
    Label1.Height = 30
    Label1.Alignment = 2
    Label1.Appearance = 0
    Label1.Caption = ""
    '
    ReDim pZ(5)
    '
    pZ(0).Width = 640
    pZ(0).Height = 480
    '
    pZ(1).Width = 352
    pZ(1).Height = 288
    '
    pZ(2).Width = 320
    pZ(2).Height = 240
    '
    pZ(3).Width = 176
    pZ(3).Height = 144
    '
    pZ(4).Width = 160
    pZ(4).Height = 120
    '
    'Прочитаем текущие размеры из файла
    FileParam = App.Path & "\param.txt"
    ff = FreeFile()
    Open FileParam For Random As ff Len = 256
        Get #ff, 1, xZ
        'Put #ff, 1, firstRec
    Close ff
    '
    'Есть такой формат картинки?
    For i = 0 To 4
        If xZ.Width = pZ(i).Width And xZ.Height = pZ(i).Height Then
            mZ = pZ(i)  'Нашли размер
            GoTo mk
        End If
    Next i
    mZ = pZ(0)  'Если такого размера нет, то установим 640*480
mk:
    '
    For j = 0 To UBound(pZ) - 1
        List1.AddItem pZ(j).Width & " * " & pZ(j).Height
    Next j
    '
    List1.ListIndex = i     'Индекс i такой размер есть!
    '
    Load Picture1(1)
    '
    levelSENS = 20  'Уровень срабатывания датчика движения
    '
    Clipboard.Clear
    STARTCAM
    Command2.Enabled = False 'Запретить повторный запуск
End Sub
'
Private Sub Command1_Click()
Dim newF As String
    '
    'STOPCAM
    tempFilename = App.Path & "\Screen\img-" & Format(Now, "mmddyy-hhmmss") & ".bmp"
    'newF = "d:\img-" & Format(Now, "mmddyy-hhmmss") & ".bmp"
    SavePicture Picture1(0).Image, tempFilename
    'FileCopy tempFilename, newF
End Sub
'
Private Sub Command2_Click()
    tempFilename = ""
    STARTCAM
End Sub
'
'Задать новые размеры
'Задаваемый размер должен поддерживаться камерой
Private Sub GetSizePic(newW As Long, newH As Long)
Dim rt As Long
    '
    'Если текущий размер совпадает с новым - выход и ничего не меняем
    If mZ.Width = newW And mZ.Height = newH Then Exit Sub
    '
    mZ.Width = newW
    mZ.Height = newH
    '
    If SendMessage(mCapHwnd, WM_CAP_DRIVER_CONNECT, 0, 0) <> 0 Then
        rt = SendMessage(mCapHwnd, WM_CAP_GET_VIDEOFORMAT, Len(Bt), Bt)
        Bt.bmiHeader.biWidth = mZ.Width
        Bt.bmiHeader.biHeight = mZ.Height
        'Bt.bmiHeader.biSize = Len(Bt.bmiHeader)
        'Bt.bmiHeader.biPlanes = 1
        'Bt.bmiHeader.biBitCount = 24
        rt = SendMessage(mCapHwnd, WM_CAP_SET_VIDEOFORMAT, Len(Bt), Bt)
    End If
    'Picture1(0).Refresh
 
    mCapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, mZ.Width, mZ.Height, Me.hwnd, 0)
    DoEvents
    SendMessage mCapHwnd, CONNECT, 0, 0
    Call newSIZE(mZ)
End Sub
'
Private Sub Command4_Click()
 Dim temp As Long
 'If startcap = True Then
  temp = SendMessage(mCapHwnd, WM_CAP_DLG_VIDEOFORMAT, 0&, 0&)
'End If
End Sub
'
Private Sub List1_Click()
Dim i As Integer
Dim val As Integer
    '
    val = Check2.Value
    Check2.Value = 0
    i = List1.ListIndex
    Call GetSizePic(pZ(i).Width, pZ(i).Height)
    Sleep 2000
    If val = 1 Then Check2.Value = 1
    
End Sub
'
Private Sub Timer1_Timer()
    On Error Resume Next
    '
    SendMessage mCapHwnd, GET_FRAME, 0, 0
    SendMessage mCapHwnd, COPY, 0, 0
    Picture1(0).Picture = Clipboard.GetData
    Clipboard.Clear
    '
End Sub
'
Sub STOPCAM()
    DoEvents: SendMessage mCapHwnd, DISCONNECT, 0, 0
    Timer1.Enabled = False
End Sub
'
Sub STARTCAM()
Dim rt As Long
    '
    mCapHwnd = capCreateCaptureWindow("WebcamCapture", 0, 0, 0, mZ.Width, mZ.Height, Me.hwnd, 0)
    DoEvents
    rt = SendMessage(mCapHwnd, CONNECT, 0, 0)
    '
    If rt = 0 Then  'Возможно попали в режим выбора камеры
        'Выбрали камеру и запускаем снова
        rt = SendMessage(mCapHwnd, CONNECT, 0, 0)
    End If
    'Опять проверим
    If rt = 0 Then
        'Выходим
        Unload Me
    Else
        'Запустим таймер для показа картинок
        Timer1.Enabled = True
    End If
End Sub
'
Private Sub Form_Unload(Cancel As Integer)
  Screen.MousePointer = vbDefault
  STOPCAM
End Sub
'
Private Sub Command3_Click()
  Unload Me
End Sub
'
Private Function newSIZE(bZ As picSIZE) As Integer
Dim ff As Integer
    '
    FileParam = App.Path & "\param.txt"
    ff = FreeFile()
    Open FileParam For Random As ff Len = 256
        'Get #ff, 1, xZ
        Put #ff, 1, bZ
    Close ff
End Function
'
Private Sub Timer2_Timer()
Static sT As Integer
    '
    If sT = 100 Then
        Form1.Caption = "Остановите программу и очистите папку SnapShot"
    Else
        tempFilename = App.Path & "\SnapShot\img-" & Format(Now, "mmddyy-hhmmss") & ".bmp"
        SavePicture Picture1(0).Image, tempFilename
        sT = sT + 1
    End If
End Sub
'
'Фото для датчика движения
Private Function Detect() As Long
Dim rt As Double, i As Integer, j As Integer
Dim X As Long, xy As Long, p1 As Long, p2 As Long, dp As Long
Dim dt As Double, sDESTR As Double
    '
    xy = Picture1(0).ScaleWidth * Picture1(0).ScaleHeight
    For i = 1 To Picture1(0).ScaleWidth
        For j = 1 To Picture1(0).ScaleHeight
            p1 = GetPixel(Picture1(0).hdc, i, j)
            p2 = GetPixel(Picture1(1).hdc, i, j)
            dp = Abs(p1 - p2)
            dt = dt + dp
            sDESTR = dt
            sDESTR = sDESTR / Picture1(0).ScaleHeight
            sDESTR = sDESTR / Picture1(0).ScaleWidth
            sDESTR = sDESTR / 16777215
            sDESTR = sDESTR * 1000
            If sDESTR > levelSENS Then
                dt = sDESTR + 1
                GoTo ext
            End If
        Next j
    Next i
    dt = dt / Picture1(0).ScaleHeight
    dt = dt / Picture1(0).ScaleWidth
    dt = dt / 16777215
    dt = dt * 1000
ext:
    Detect = CLng(dt)
End Function
'
Private Sub Timer3_Timer()
Dim dt As Long
    '
    'Включен детектор движения?     Сравним картинки.
    If Check2.Value = 1 Then        'Включен
        If Check2.Tag = 0 Then  '1-й проход
            Set Picture1(1).Picture = Picture1(0).Picture
            Check2.Tag = 1
        Else
            dt = Detect     'Сравнение
            Label1.Caption = dt
            'Срабатывание будет при 20
            If dt > 20 Then
                Timer4.Enabled = True
            End If
            Set Picture1(1).Picture = Picture1(0).Picture
        End If
    End If
End Sub
'
Private Sub Timer4_Timer()
Static sT As Integer
    '
    If sT = 0 Then
        Beep
        Label1.BackColor = &HC0&
        sT = sT + 1
    Else
        Timer4.Enabled = False
        Label1.BackColor = &H80000005
        sT = 0
    End If
End Sub