frmvideocapture.frm

优秀的面部识别程序,用VB开发的

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmVideoCapture 
   BackColor       =   &H8000000C&
   Caption         =   "Video"
   ClientHeight    =   2775
   ClientLeft      =   2850
   ClientTop       =   3405
   ClientWidth     =   6165
   Icon            =   "frmVideoCapture.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   185
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   411
   StartUpPosition =   2  'CenterScreen
   Begin VB.PictureBox picRed 
      Height          =   2145
      Left            =   2955
      MousePointer    =   2  'Cross
      ScaleHeight     =   204.412
      ScaleMode       =   0  'User
      ScaleWidth      =   187.097
      TabIndex        =   8
      Top             =   5010
      Visible         =   0   'False
      Width           =   2670
   End
   Begin VB.Frame Frame1 
      Height          =   615
      Left            =   0
      TabIndex        =   4
      Top             =   2160
      Width           =   2655
      Begin VB.CommandButton cmdStop 
         Enabled         =   0   'False
         Height          =   495
         Left            =   480
         Picture         =   "frmVideoCapture.frx":0442
         Style           =   1  'Graphical
         TabIndex        =   6
         Top             =   120
         Width           =   495
      End
      Begin VB.CommandButton cmdPlay 
         Height          =   495
         Left            =   0
         Picture         =   "frmVideoCapture.frx":086C
         Style           =   1  'Graphical
         TabIndex        =   5
         Top             =   120
         Width           =   495
      End
      Begin MSComctlLib.Slider sldSensitivity 
         Height          =   375
         Left            =   1050
         TabIndex        =   7
         Top             =   195
         Width           =   1530
         _ExtentX        =   2699
         _ExtentY        =   661
         _Version        =   393216
         Min             =   50
         Max             =   99
         SelStart        =   50
         TickStyle       =   3
         TickFrequency   =   5
         Value           =   50
      End
   End
   Begin VB.PictureBox picFaces 
      BackColor       =   &H00000000&
      Height          =   2160
      Left            =   30
      MousePointer    =   2  'Cross
      ScaleHeight     =   100
      ScaleMode       =   0  'User
      ScaleWidth      =   100
      TabIndex        =   3
      Top             =   0
      Width           =   2655
   End
   Begin VB.PictureBox picMotion 
      Height          =   1080
      Left            =   510
      MousePointer    =   2  'Cross
      ScaleHeight     =   54.839
      ScaleMode       =   0  'User
      ScaleWidth      =   56.364
      TabIndex        =   2
      Top             =   5010
      Visible         =   0   'False
      Width           =   1455
   End
   Begin VB.Timer timGrab 
      Interval        =   500
      Left            =   120
      Top             =   1440
   End
   Begin VB.PictureBox picCapture2 
      BackColor       =   &H00000000&
      Height          =   2160
      Left            =   2640
      MousePointer    =   2  'Cross
      ScaleHeight     =   100
      ScaleMode       =   0  'User
      ScaleWidth      =   100
      TabIndex        =   1
      Top             =   0
      Width           =   3495
   End
   Begin VB.PictureBox picCapture 
      Height          =   2160
      Left            =   2640
      MousePointer    =   2  'Cross
      ScaleHeight     =   2100
      ScaleWidth      =   3435
      TabIndex        =   0
      Top             =   0
      Width           =   3495
   End
   Begin VB.Shape shaBorder2 
      BackColor       =   &H00808080&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00808080&
      FillColor       =   &H00404040&
      Height          =   3495
      Left            =   0
      Top             =   3360
      Width           =   2655
   End
   Begin VB.Shape shaBorder 
      BackColor       =   &H00808080&
      BackStyle       =   1  'Opaque
      BorderColor     =   &H00808080&
      FillColor       =   &H00404040&
      Height          =   3495
      Left            =   0
      Top             =   0
      Width           =   2655
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuRecognition 
      Caption         =   "&Recognition"
      Begin VB.Menu mnuTraining 
         Caption         =   "&Training"
      End
      Begin VB.Menu mnuTesting 
         Caption         =   "T&esting"
      End
   End
   Begin VB.Menu mnuOptions 
      Caption         =   "&Options"
      Begin VB.Menu mnuFormat 
         Caption         =   "&Format..."
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuSource 
         Caption         =   "S&ource..."
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuDisplay 
         Caption         =   "&Display..."
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuspacer5 
         Caption         =   "-"
      End
      Begin VB.Menu mnuCompression 
         Caption         =   "&Compression..."
      End
      Begin VB.Menu mnuspacer6 
         Caption         =   "-"
      End
      Begin VB.Menu mnuDriver 
         Caption         =   "<none>"
         Enabled         =   0   'False
         Index           =   0
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "&Help"
      Begin VB.Menu mnuAbout 
         Caption         =   "&About"
      End
   End
End
Attribute VB_Name = "frmVideoCapture"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private hCapWnd As Long       ' Handle to the Capture Windows
Private nDriverIndex As Long  ' video driver index (default 0)
Private m_CapParams As CAPTUREPARMS

'Public property to prevent reentrancy in Form_Resize event
Public AutoSizing As Boolean

Public vidCapture As New ClassVideoCapture
Public LeftBorderWidth As Integer
Public minBorderHeight As Integer

Dim Busy As Boolean
Dim Play As Boolean
Dim VideoConnected As Boolean

Dim faces As New ClassFaceRecogniser


Public Property Get capwnd() As Long
'read-only public property to allow other forms to retrieve hwnd of Cap Window
  capwnd = hCapWnd
End Property


Public Property Get MenuHeight() As Long
'read-only properties for sizing
  MenuHeight = GetSystemMetrics(SM_CYMENU)
End Property


Public Property Get CaptionHeight() As Long
  CaptionHeight = GetSystemMetrics(SM_CYCAPTION)
End Property



Public Sub grabFrame(pic As PictureBox)
  Dim FileName As String
  Dim retVal As Boolean
  
  Busy = True
  Call capGrabFrame(hCapWnd)
  
  FileName = App.Path & "\bob.bmp"
  retVal = capFileSaveDIB(hCapWnd, FileName)
  If (retVal = False) Then
    MsgBox "Problem saving frame", vbInformation, App.Title
  End If
  pic.Picture = LoadPicture(FileName)
  
  Call vidCapture.update(pic)
  Busy = False
End Sub




Private Sub cmdPlay_Click()
  Play = True
  cmdStop.Enabled = True
  cmdPlay.Enabled = False
  sldSensitivity.Enabled = False
End Sub


Private Sub cmdStop_Click()
  Play = False
  cmdStop.Enabled = False
  cmdPlay.Enabled = True
  sldSensitivity.Enabled = True
End Sub

Private Sub Form_Load()
  Dim retVal As Boolean
  Dim numDevs As Long
  Dim FileName As String
  Const image_Width = 25
  Const image_Height = 25

  Busy = True
  Play = False
  VideoConnected = False
  
  frmVideoCapture.MousePointer = 11
  
  FileName = App.Path & "\faces.rec"
  
  Call faces.init
  Call faces.load
  sldSensitivity.Value = Int(faces.getRecognitionThreshold * 100)
  
  LeftBorderWidth = shaBorder.width
  minBorderHeight = shaBorder.height

  Set vidCapture = New ClassVideoCapture
  Call vidCapture.init(image_Width, image_Height)
  vidCapture.processRGB = False

  'detect hardware
  numDevs = VBEnumCapDrivers(Me)
  If (numDevs <> 0) Then
  
    nDriverIndex = Val(GetSetting(App.Title, "driver", "index", "0"))
  
    'if invalid entry is in registry use default (0)
    If (mnuDriver.UBound < nDriverIndex) Then
      nDriverIndex = 0
    End If
    mnuDriver(nDriverIndex).Checked = True
  
    'Create Capture Window
    hCapWnd = capCreateCaptureWindow("VB CAP WINDOW", WS_CHILD Or WS_VISIBLE, 0, 0, 160, 120, picCapture.hWnd, 0)
    If (hCapWnd <> 0) Then
  
      retVal = ConnectCapDriver(hCapWnd, nDriverIndex)
      If (retVal = False) Then
        MsgBox "could not connect to capture driver", vbInformation, App.Title
        Else
        #If (USECALLBACKS = 1) Then
          'if we have a valid capwnd we can enable our status callback function
          Call capSetCallbackOnStatus(hCapWnd, AddressOf StatusProc)
        #End If
        VideoConnected = True
      End If
 
      Else
    
      MsgBox "could not create capture window", vbCritical, App.Title
    End If
    
    Else

    MsgBox "No capture hardware detected", vbCritical, App.Title
  End If
  
  frmVideoCapture.MousePointer = 0
  Busy = False
  
  If (Not VideoConnected) Then
    Unload frmVideoCapture
    frmTesting.show
  End If
  
End Sub


Public Sub Form_Resize()
  Dim retVal As Boolean
  Dim capStat As CAPSTATUS

  'Get the capture window attributes
  retVal = capGetStatus(hCapWnd, capStat)
  If (retVal) Then
    picCapture.left = LeftBorderWidth
    picCapture.width = capStat.uiImageWidth
    picCapture.ScaleWidth = picCapture.width
    picCapture.height = capStat.uiImageHeight
    picCapture.ScaleHeight = picCapture.height
    
    picCapture2.left = LeftBorderWidth
    picCapture2.width = capStat.uiImageWidth
    picCapture2.ScaleWidth = 100
    picCapture2.height = capStat.uiImageHeight
    picCapture2.ScaleHeight = 100
    
    'picFaces.left = LeftBorderWidth
    'picFaces.width = capStat.uiImageWidth
    'picFaces.ScaleWidth = 100
    'picFaces.height = capStat.uiImageHeight
    'picFaces.ScaleHeight = 100
  End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

  Call faces.Free
  
  If (VideoConnected) Then
  
    'save trivial settings
    If (Me.WindowState = vbDefault) Then
      Call SaveSetting(App.Title, "preferences", "left", Me.left)
      Call SaveSetting(App.Title, "preferences", "top", Me.top)
    End If

    'unsubclass if necessary
    #If USECALLBACKS = 1 Then
      'Disable status callback
      Call capSetCallbackOnStatus(hCapWnd, 0&)
    #End If

    'disconnect VFW driver
    Call basVFW.capDriverDisconnect(hCapWnd)
    'destroy CapWnd
    If (hCapWnd <> 0) Then Call DestroyWindow(hCapWnd)
    
  End If
  
End Sub


Private Sub mnuAbout_Click()
  frmAbout.show 1
End Sub

Private Sub mnuCompression_Click()
  Call capDlgVideoCompression(hCapWnd)
End Sub



Private Sub mnuDisplay_Click()
  Call capDlgVideoDisplay(hCapWnd)
End Sub


Private Sub mnuDriver_Click(Index As Integer)
  Dim retVal As Boolean
    
  retVal = ConnectCapDriver(hCapWnd, Index)
  If (retVal = False) Then
    MsgBox "could not connect to capture driver", vbInformation, App.Title
    Else
    Call SaveSetting(App.Title, "driver", "index", CStr(Index)) 'save selected device index
  End If
End Sub


Private Sub mnuExit_Click()
  Unload Me
End Sub

Private Sub mnuFormat_Click()
  Call capDlgVideoFormat(hCapWnd)
  Call ResizeCaptureWindow(hCapWnd, LeftBorderWidth, minBorderHeight)
End Sub


Private Sub mnuSource_Click()
'Display the Video Source dialog when "Source" is selected from the menu bar
  Call capDlgVideoSource(hCapWnd)
End Sub


Private Sub findFaces()
  If (Play) Then
    Call faces.IdentifyFaceWithinPicture(picCapture2, 0, 0, picCapture2.ScaleWidth, picCapture2.ScaleHeight)
  End If
  DoEvents
  If (Play) Then
    Call faces.showFaceProbabilities(picFaces)
  End If
End Sub


Private Sub mnuTesting_Click()
  frmTesting.show
  Unload frmVideoCapture
End Sub


Private Sub mnuTraining_Click()
  frmTraining.show
  Unload frmVideoCapture
End Sub


Private Sub sldSensitivity_Change()
  Call faces.setRecognitionThreshold(sldSensitivity.Value / 100)
End Sub


Private Sub timGrab_Timer()
  If (Not Busy) And (Play) Then
    Call grabFrame(picCapture2)
    DoEvents
    If (Play) Then
      Call findFaces
    End If
  End If
End Sub