Programación de cámara sin controlador vb6, código fuente

El siguiente es un código de controlador de cámara VB que escribí hace unos años (referencia). No sé si todavía se puede usar ahora, porque el archivo generalmente es muy largo. Una pequeña parte espero que pueda serle útil (o contácteme y le daré el código fuente)

Private Sub Form_Load()

En caso de error, reanudar a continuación.

Dim retVal As Boolean

Dim numDevs As Long

bCaramaPlaying = True

'cargar configuraciones triviales primero

Me.BackColor = Val(GetSetting(App .Title, "preferences", "backcolor", "amp; H404040")) 'predeterminado en gris oscuro

numDevs = VBEnumCapDrivers(Me)

Si 0 = numDevs Entonces

MsgBox "¡Dispositivo de captura de vídeo no encontrado!", vbCritical, App.Title

' frmPlayer.Visible = True

' Si bIsVisible = True And vbPlayFormIsVisible = True And vbFrmPlayFrameHided = False Then

' frmPlayFrame.Visible = True

' Finaliza si

Descargarme

Salir de Sub

Fin si

nDriverIndex = Val(GetSetting(App.Title, "driver", "index", "0"))

'si hay una entrada no válida en el registro, utilice el valor predeterminado (0)

If mnuDriver.UBound lt nDriverIndex Then

nDriverIndex = 0

End If

mnuDriver(nDriverIndex).Checked = True

'//Crear ventana de captura

'Llamar a capGetDriverDescription( nDriverIndex, lpszName, 100, lpszVer, 100 '// Recupera el controlador info

hCapWnd = capCreateCaptureWindow("VB CAP WINDOW", WS_CHILD Or WS_VISIBLE, 0, 0, 160, 120, Me.hWnd, 0)

Si 0 = hCapWnd Entonces

MsgBox "¡No se puede crear la ventana de captura!", vbCritical, App.Title

Salir de Sub

End If

retVal = ConnectCapDriver(hCapWnd, nDriverIndex)

Si False = retVal Entonces

MsgBox "¡No se puede conectar al dispositivo de video!", vbInformation, App.Title

Else

#If USECALLBACKS = 1 Luego

' si tenemos un capwnd válido podemos habilitar nuestra función de devolución de llamada de estado

Llamar a capSetCallbackOnStatus(hCapWnd, AddressOf StatusProc)

Debug.Print "- --Devolución de llamada configurada en el estado de captura---"

#End If

End If

'// Establece la función de devolución de llamada de transmisión de video

' capSetCallbackOnVideoStream lwndC, AddressOf MyVideoStreamCallback

' capSetCallbackOnFrame lwndC, AddressOf MyFrameCallback

Dim bPlayFrameTop como booleano

bPlayFrameTop = GetSetting(MyName, "configuración" amp ; "-" amplificador; Trim(Str(App.Major)) amp; "-" amplificador(Str(App.Minor)), "bPlayFrameTop", "False")

Si bPlayFrameTop = True Then

Me.mnuOptionTop.Checked = True

'Poner delante

SetWindowPos Me.hWnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, Me .Top / Screen.TwipsPerPixelY, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, & H20

Else

Me.mnuOptionTop.Checked = False

'No en la parte superior

SetWindowPos Me.hWnd, HWND_NOTOPMOST, Me.Left / Screen.T

wipsPerPixelX, Me.Top / Screen.TwipsPerPixelY, Me.Width / Screen.TwipsPerPixelX, Me.Height / Screen.TwipsPerPixelY, & H20

End If

Me.Left = ( Pantalla .Width - Me.Width) / 2

Me.Top = (Screen.Height - Me.Height) / 2

Me.picShowMenu.ZOrder 0

End Sub

'El siguiente es un archivo de módulo

Option Explicit

'Las rutinas específicas de la aplicación están aquí

Public Const ONE_MEGABYTE As Largo = 1048576

'Const pública MMSYSERR_NOERROR Mientras largo = 0

Const pública INDEX_15_MINUTES Mientras largo = 27000 '(30fps * 60seg * 15min)

Const pública INDEX_3_HOURS As Long = 324000 ' (30fps * 60seg * 60min * 3hr)

Función pública GetFreeSpace() As Long

'esta función obtiene la cantidad de espacio libre en disco y agrega el tamaño

'del archivo de captura actual

Dim freedisk As Long

Atenuar ruta como cadena

'obtener longitud del archivo Cap

ruta = capFileGetCaptureFile(frmCaramaMain.capwnd)

Si ruta lt;gt "" Entonces

En caso de error, reanudar siguiente

freedisk = FileLen(ruta )

freedisk = freedisk / ONE_MEGABYTE

End If

'ahora obtiene espacio libre en disco de esa unidad

path = Left$( ruta, 3)

GetFreeSpace = freedisk vbGetAvailableMBytes(ruta)

Función final

Sub ResizeCaptureWindow(ByVal hCapWnd As Long)

Dim retVal As Boolean

Dim capStat As CAPSTATUS

'Obtener los atributos de la ventana de captura

retVal = capGetStatus(hCapWnd, capStat)

Si retVal Entonces

'Cambiar el tamaño del formulario principal para que quepa

Llamar a SetWindowPos(frmCaramaMain.hWnd, _

0amp;, _

0amp;, _

0amp;, _

capStat.uiImageWidth (frmCaramaMain.XBorder * 2), _

capStat.uiImageHeight (frmCaramaMain.YBorder * 4) _

frmCaramaMain.CaptionHeight frmCaramaMain.MenuHeight, _

Swp_nomove o SWP_NOZORDER o SWP_NOSENDCHANGING)

'Cambiar el tamaño de la ventana de captura para formatear el tamaño

Llamar a SetWindowPos(hCapWnd, _

0amp;, _

0amp;, _

0amp;, _

capStat.uiImageWidth, _

capStat.uiImageHeight, _

Swp_nomove o SWP_NOZORDER o SWP_NOSENDCHANGING)

Finalizar si

Llamada a frmCaramaMain.Form_Resize

End Sub

Función pública VBEnumCapDrivers(ByRef frm As frmCaramaMain) Siempre

'/*

' * Enumere los posibles controladores de captura y agregue la lista al menú Opciones

' * Esta función solo se llama una vez al inicio.

' *. Devuelve 0 si no hay controladores disponibles.

' */

Const MAXVIDDRIVERS As Long = 9

Const CAP_STRING_MAX

Mientras = 128

Atenuar numDrivers mientras

Atenuar cadenas de controladores (0 a MAXVIDDRIVERS - 1) como cadena

Atenuar índice mientras

Atenuar dispositivo como cadena

Atenuar versión como cadena

Atenuar menú como VB.menu

Dispositivo = Cadena$(CAP_STRING_MAX, 0)

Versión = String$(CAP_STRING_MAX, 0)

numDrivers = 0

Para Índice = 0 A (MAXVIDDRIVERS - 1) Paso 1

Si 0 lt ;gt; capGetDriverDescription(Índice, _

Dispositivo, _

CAP_STRING_MAX, _

Versión, _

CAP_STRING_MAX) _ p>

Luego

'extiende el menú

Si Index gt 0 Entonces

Cargar frm.mnuDriver(Index)

End If

Set menu = frm.mnuDriver(Index) 'obtiene un puntero de objeto al nuevo menú

'Concatena el nombre del dispositivo y las cadenas de versión al nuevo elemento del menú

menu.Caption = Left$(Dispositivo, InStr(Dispositivo, vbNullChar) - 1)

menu.Caption = menu.Caption amp; p> menú. Caption = menu.Caption & Left$(Version, InStr(Version, vbNullChar) - 1)

menu.Enabled = True

numDrivers = numDrivers 1

Finalizar si

Siguiente

VBEnumCapDrivers = numDrivers

Finalizar función

Pub

Función lic ConnectCapDriver(ByVal hCapWnd As Long, ByVal nDriverIndex As Long) Como booleano

Dim retVal Como booleano

Atenuar mayúsculas como CAPDRIVERCAPS

Dim i As Long

Debug.Assert (nDriverIndex lt; 10) And (nDriverIndex gt; = 0)

'// Conecta la ventana de captura al controlador

retVal = capDriverConnect (hCapWnd, nDriverIndex)

Si False = retVal Entonces

'return False

Salir de la función

Finalizar si

'// Obtener las capacidades del controlador de captura

retVal = capDriverGetCaps(hCapWnd, Caps)

If False lt;gt; retVal Then

' restablecer menús (muy específicos de la aplicación)

Con frmCaramaMain

For i = 0 To .mnuDriver.UBound

.mnuDriver(i).Checked = False ' asegúrese de que todos los controladores estén desmarcados

Siguiente

.mnuDriver(nDriverIndex).Checked = True 'luego verifique el nuevo controlador

'deshabilite todos los elementos del menú de funciones de hardware

.mnuSource.Enabled = False

.mnuFormat.Enabled = False

.mnuDisplay.Enabled = False

.mnuOverlay.Enabled = False

'Luego habilite los que son compatibles con el nuevo controlador

If Caps.fHasDlgVideoSource lt;gt 0 Then .mnuSource.Enabled = True