Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
176 lines (146 sloc) 6.87 KB
Imports System.Windows.Forms
Imports System.Drawing
Imports System.Runtime.InteropServices
Module ABWebCamTools
Public Class ABWebCamera
#Region "Apis y Constantes"
' Constantesss
Private Const WM_USER As Short = &H400S
Private Const WM_CAP_DRIVER_CONNECT As Integer = WM_USER + 10
Private Const WM_CAP_DRIVER_DISCONNECT As Integer = WM_USER + 11
Private Const WM_CAP_SET_VIDEOFORMAT As Integer = WM_USER + 45
Private Const WM_CAP_SET_PREVIEW As Integer = WM_USER + 50
Private Const WM_CAP_SET_PREVIEWRATE As Integer = WM_USER + 52
Private Const WM_CAP_GET_FRAME As Long = 1084
Private Const WM_CAP_SET_SCALE = WM_CAP_START + 53
Private Const WM_CAP_COPY As Long = 1054
Private Const WM_CAP_START As Long = WM_USER
Private Const WM_CAP_STOP As Long = (WM_CAP_START + 68)
Private Const WM_CAP_SEQUENCE As Long = (WM_CAP_START + 62)
Private Const WM_CAP_SET_SEQUENCE_SETUP As Long = (WM_CAP_START + 64)
Private Const WM_CAP_FILE_SET_CAPTURE_FILEA As Long = (WM_CAP_START + 20)
Private Const WM_CAP_EDIT_COPY = WM_CAP_START + 30
Private Const WS_CHILD As Integer = &H40000000
Private Const WS_VISIBLE As Integer = &H10000000
Private Const SWP_NOMOVE As Short = &H2S
Private Const SWP_NOZORDER As Short = &H4S
Private Const SWP_NOSIZE = 1
Private Const HWND_BOTTOM = 1
' Api's
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Short, ByVal lParam As String) As Integer
Private Declare Function capGetDriverDescriptionA Lib "avicap32.dll" (ByVal wDriver As Short, ByVal lpszName As String, ByVal cbName As Integer, ByVal lpszVer As String, ByVal cbVer As Integer) As Boolean
Private Declare Function capCreateCaptureWindowA Lib "avicap32.dll" (ByVal lpszWindowName As String, ByVal dwStyle As Integer, ByVal x As Integer, ByVal y As Integer, ByVal nWidth As Integer, ByVal nHeight As Short, ByVal hWndParent As Integer, ByVal nID As Integer) As Integer
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Integer, ByVal Msg As Integer, ByVal wParam As Integer, <MarshalAs(UnmanagedType.AsAny)> ByVal lParam As Object) As Integer
Private Declare Function SetWindowPos Lib "user32" Alias "SetWindowPos" (ByVal hwnd As Integer, ByVal hWndInsertAfter As Integer, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer) As Integer
#End Region
Private _Device As String
Private _hWnd As Integer
Private _FramesPorrSegundo As Integer = 30
Private OutputHeight As Integer = 240
Private OutputWidth As Integer = 360
Private WithEvents _Picture As PictureBox
Public Property Running() As Boolean
Public Property FramesPorSegundo() As Integer
Get
Return _FramesPorrSegundo
End Get
Set(ByVal value As Integer)
_FramesPorrSegundo = value
ReiniciarCamera()
End Set
End Property
Public ReadOnly Property FotogramaActual() As Image
Get
If Not (_Picture Is Nothing) Then Return _Picture.Image
Return Nothing
End Get
End Property
Public Sub IniciarCaptura(ByVal PB As PictureBox)
If Me.Running Then
Throw New CamaraYaHaSidoInicializadaEx
Else
Try
_Picture = PB
_hWnd = capCreateCaptureWindowA(_Device, WS_VISIBLE Or WS_CHILD, 0, 0, OutputWidth, CShort(OutputHeight), PB.Handle.ToInt32, 0)
ConfigurarCamara()
Catch Ex As Exception
_Picture = Nothing
Throw Ex
End Try
End If
End Sub
Public Sub DetenerCaptura()
If Me.Running Then
SendMessage(_hWnd, WM_CAP_DRIVER_DISCONNECT, 0, CType(0, String)) 'Descoenctar
_Picture = Nothing
Me.Running = False
Else
Throw New CamaraNoInicializadaEx
End If
End Sub
Public Sub ReiniciarCamera()
If _Running Then
DetenerCaptura()
Application.DoEvents() 'Continuar Con los eventos mientras se detiene y se enciende de nuevo la camara
ConfigurarCamara()
Else
Throw New CamaraNoInicializadaEx
End If
End Sub
Private Sub ConfigurarCamara()
'Encender camara
If SendMessage(_hWnd, WM_CAP_DRIVER_CONNECT, CType(_Device, Short), CType(0, String)) = 1 Then
Dim CameraFrameRate As Short = CType(1000 \ _FramesPorrSegundo, Short)
SendMessage(_hWnd, WM_CAP_SET_SCALE, 1, CType(0, String))
'Le decimos el framerate, y le decimos que usaremos vista preliminar
SendMessage(_hWnd, WM_CAP_SET_PREVIEWRATE, CameraFrameRate, CType(0, String))
SendMessage(_hWnd, WM_CAP_SET_PREVIEW, 1, CType(0, String))
Me.Running = True
SetWindowPos(_hWnd, HWND_BOTTOM, 0, 0, _Picture.Width, _Picture.Height, SWP_NOMOVE Or SWP_NOZORDER)
Else
Me.Running = False
Throw New CamaraNoConfiguradaEx
End If
End Sub
Public Function CapturarImagen() As Image
Dim data As IDataObject
Dim bmap As Image
'Copiar la imagen al portapapeles
SendMessage(_hWnd, WM_CAP_EDIT_COPY, 0, CType(0, String))
'Tomar la imagen del portapapeles y comvertirlo a image
data = Clipboard.GetDataObject()
If data.GetDataPresent(GetType(System.Drawing.Bitmap)) Then
bmap = CType(data.GetData(GetType(System.Drawing.Bitmap)), Image)
Return bmap
Else
Return Nothing
End If
End Function
End Class
#Region "Excepciones"
Public Class NoExistenCamarasEx
Inherits Exception
Public Sub New()
MyBase.New("No Existen camaras web instaladas en el equipo.")
End Sub
End Class
Public Class CamaraNoInicializadaEx
Inherits Exception
Public Sub New()
MyBase.New("La camara no ha sido inicializada")
End Sub
End Class
Public Class CamaraNoConfiguradaEx
Inherits Exception
Public Sub New()
MyBase.New("La configuracion de la camara ha fallado")
End Sub
End Class
Public Class CamaraYaHaSidoInicializadaEx
Inherits Exception
Public Sub New()
MyBase.New("La camara ya ha sido inicializada")
End Sub
End Class
#End Region
End Module