bascapture.bas

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

Attribute VB_Name = "basCapture"
'****************************************************************
'*  VB file:   CapApp.bas...
'*
'*  created:        1998 by Ray Mercer
'*  last modified:  12/2/98 by Ray Mercer (added comments)
'*
'*  Useful routines for creating a video capture application in
'*  Visual Basic.  Loosely based on routines found in the Microsoft
'*  VidCap32 application in the C-Language VFW Developer's kit
'*
'*
'*  Copyright (c) 1998 Ray Mercer.  All rights reserved.
'****************************************************************


Option Explicit

'application specific routines are here

'Public Const ONE_MEGABYTE As Long = 1048576
Public Const MMSYSERR_NOERROR As Long = 0
Public Const INDEX_15_MINUTES As Long = 27000 '(30fps * 60sec * 15min)
Public Const INDEX_3_HOURS As Long = 324000 ' (30fps * 60sec * 60min * 3hr)


Public Type RGBthingy
  Value As Long
End Type

Public Type RGBpoint
  Red As Byte
  Green As Byte
  Blue As Byte
End Type


Sub ResizeCaptureWindow(ByVal hCapWnd As Long, LeftBorderWidth As Integer, minHeight As Integer)
  Dim retVal As Boolean
  Dim capStat As CAPSTATUS
  Dim hght As Integer
    
  'Get the capture window attributes
  retVal = capGetStatus(hCapWnd, capStat)
        
  If (retVal) Then
    
    'check for minimum form height
    hght = capStat.uiImageHeight + frmVideoCapture.CaptionHeight + frmVideoCapture.MenuHeight
    If (hght < minHeight) Then
      hght = minHeight
    End If
    
    'Resize the main form to fit
    Call SetWindowPos(frmVideoCapture.hWnd, _
                    0&, _
                    0&, _
                    0&, _
                    capStat.uiImageWidth + LeftBorderWidth, _
                    hght, _
                    SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSENDCHANGING)
    'Resize the capture window to format size
    Call SetWindowPos(hCapWnd, _
                    0&, _
                    0&, _
                    0&, _
                    capStat.uiImageWidth + LeftBorderWidth, _
                    capStat.uiImageHeight, _
                    SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSENDCHANGING)
  End If
  Call frmVideoCapture.Form_Resize
End Sub


Public Function VBEnumCapDrivers(ByRef frm As Form) As Long
'/*
' * Enumerate the potential capture drivers and add the list to the Options
' * menu.  This function is only called once at startup.
' * Returns 0 if no drivers are available.
' */
Const MAXVIDDRIVERS As Long = 9
Const CAP_STRING_MAX As Long = 128
Dim numDrivers As Long
Dim driverStrings(0 To MAXVIDDRIVERS - 1) As String
Dim index As Long
Dim Device As String
Dim Version As String
Dim menu As VB.menu
 
Device = String$(CAP_STRING_MAX, 0)
Version = String$(CAP_STRING_MAX, 0)
numDrivers = 0
For index = 0 To (MAXVIDDRIVERS - 1) Step 1
    If 0 <> capGetDriverDescription(index, _
                                    Device, _
                                    CAP_STRING_MAX, _
                                    Version, _
                                    CAP_STRING_MAX) _
                                                            Then
        'extend the menu
        If index > 0 Then
            load frm.mnuDriver(index)
        End If
        Set menu = frm.mnuDriver(index) 'get an object pointer to the new menu
        'Concatenate the device name and version strings to the new menu item
        menu.Caption = left$(Device, InStr(Device, vbNullChar) - 1)
        menu.Caption = menu.Caption & " "
        menu.Caption = menu.Caption & left$(Version, InStr(Version, vbNullChar) - 1)
        menu.Enabled = True
        numDrivers = numDrivers + 1
    End If

Next
VBEnumCapDrivers = numDrivers
End Function


Public Function getCaptureDrivers(ByRef frm As Form) As Long
'Enumerate the potential capture drivers and add the list to the Options
'menu.  This function is only called once at startup. Returns 0 if no drivers are available.

  Const MAXVIDDRIVERS As Long = 9
  Const CAP_STRING_MAX As Long = 128
  Dim numDrivers As Long
  Dim driverStrings(0 To MAXVIDDRIVERS - 1) As String
  Dim index As Long
  Dim Device As String
  Dim Version As String
  Dim menu As VB.menu
 
  Device = String$(CAP_STRING_MAX, 0)
  Version = String$(CAP_STRING_MAX, 0)
  numDrivers = 0
  For index = 0 To (MAXVIDDRIVERS - 1) Step 1
    If 0 <> capGetDriverDescription(index, _
                                    Device, _
                                    CAP_STRING_MAX, _
                                    Version, _
                                    CAP_STRING_MAX) _
                                                            Then
        'extend the menu
        If index > 0 Then
           load frm.mnuDriver(index)
        End If
        Set menu = frm.mnuDriver(index) 'get an object pointer to the new menu
        menu.Caption = left$(Device, InStr(Device, vbNullChar) - 1)
        menu.Caption = menu.Caption & " "
        menu.Caption = menu.Caption & left$(Version, InStr(Version, vbNullChar) - 1)
        menu.Enabled = True
        numDrivers = numDrivers + 1
    End If

  Next
  getCaptureDrivers = numDrivers
End Function



Public Function ConnectCapDriver(ByVal hCapWnd As Long, ByVal nDriverIndex As Long) As Boolean
   Dim retVal As Boolean
   Dim Caps As CAPDRIVERCAPS
   Dim i As Long
   
   Debug.Assert (nDriverIndex < 10) And (nDriverIndex >= 0)
   'Connect the capture window to the driver
    retVal = capDriverConnect(hCapWnd, nDriverIndex)
    If False = retVal Then
       'return False
       Exit Function
    End If
    'Get the capabilities of the capture driver
    retVal = capDriverGetCaps(hCapWnd, Caps)
    
    If False <> retVal Then
        'reset menus (very app-specific)
        With frmVideoCapture
            For i = 0 To .mnuDriver.UBound
              .mnuDriver(i).Checked = False 'make sure all drivers are unchecked
            Next
            .mnuDriver(nDriverIndex).Checked = True 'then check the new driver
            'disable all hardware feature menu items
            .mnuSource.Enabled = False
            .mnuFormat.Enabled = False
            .mnuDisplay.Enabled = False
            'Then enable the ones which are supported by the new driver
            If Caps.fHasDlgVideoSource <> 0 Then .mnuSource.Enabled = True
            If Caps.fHasDlgVideoFormat <> 0 Then .mnuFormat.Enabled = True
            If Caps.fHasDlgVideoDisplay <> 0 Then .mnuDisplay.Enabled = True
        End With
    End If
    
    'Resize the capture window to show the whole image
    Call ResizeCaptureWindow(hCapWnd, frmVideoCapture.LeftBorderWidth, frmVideoCapture.minBorderHeight)
    ConnectCapDriver = True
End Function



Public Function StatusProc(ByVal hCapWnd As Long, ByVal StatusCode As Long, ByVal lpStatusString As Long) As Long
  Select Case StatusCode
    Case 0 'this is recommended in docs
           'when zero is sent, clear old status messages
           'frmMain.Caption = App.Title
    Case IDS_CAP_END ' Video Capture has finished
      frmVideoCapture.Caption = App.Title
    Case IDS_CAP_STAT_VIDEOAUDIO, IDS_CAP_STAT_VIDEOONLY
      MsgBox LPSTRtoVBString(lpStatusString), vbInformation, App.Title
    Case Else
      'use this function if you need a real VB string
      'frmMain.Caption = LPSTRtoVBString(lpStatusString)
      'or, just pass the LPCSTR to a WINAPI function
      Call SetWindowTextAsLong(frmVideoCapture.hWnd, lpStatusString)
  End Select
  StatusProc = -(True) '- converts Boolean to C BOOL
End Function


'****************************************************************
'* FUNCTION LPSTRtoVBString()
'* ===============
'* by Ray Mercer
'* generic function to convert an LPCSTR to a VB String (BSTR)
'*
'* INPUTS:
'* LPSTR - a C language LPCSTR (returned from an API)
'* maxLen - optional parameter with a default value of 256
'*          defines the maximum possible length of the string
'*          pointed to by LPSTR
'*
'* RETURNS:
'* a VBString containing the string pointed to by LPSTR
'*  (works on DBCS systems too)
'****************************************************************
Private Function LPSTRtoVBString(ByVal LPSTR As Long, Optional ByVal maxlen As Long = 256) As String
    Dim sBuff  As String
    
    If LPSTR <> 0 Then 'quick and dirty input validation
        sBuff = String$(maxlen, 0) 'MCI_MAX
        If 0 <> lstrcpy(StrPtr(sBuff), LPSTR) Then 'copy mem directly
            LPSTRtoVBString = left$(sBuff, InStr(sBuff, vbNullChar) - 1) 'trim at NULL
            LPSTRtoVBString = StrConv(LPSTRtoVBString, vbUnicode) 'Convert to Unicode
        End If
    End If
End Function