Option Explicit On
Option Strict On
Public Class iCam
#Region "Api/constants"
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 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_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_FILE_SAVEAS = WM_CAP_START + 23
Private Const WM_CAP_FILE_SAVEDIB = WM_USER + 25
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 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
Public 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 BitBlt Lib "GDI32.DLL" (ByVal hdcDest As IntPtr, ByVal nXDest As Integer, ByVal nYDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hdcSrc As IntPtr, ByVal nXSrc As Integer, ByVal nYSrc As Integer, ByVal dwRop As Int32) As Boolean
#End Region
#Region "Variables"
Private iDevice As String
Private hHwnd As Integer
Private lwndC As Integer
Public StatusString As String
Public iRunning As Boolean = False
Private CamFrameRate As Integer = 15
Private OutputHeight As Integer = 760
Private OutputWidth As Integer = 1024
Public PathString As String
Private Temp As Image
#End region
Public Sub resetCam()
If iRunning Then
CloseCam()
Application.DoEvents()
StatusString = "WebCam resettata"
End If
End Sub
Public Sub initCam(ByVal parentH As Integer,ByVal currentDevice As String)
If iRunning = False Then
currentDevice = iDevice
hHwnd = capCreateCaptureWindowA(currentDevice, WS_VISIBLE Or WS_CHILD, 0, 0, OutputWidth, CShort(OutputHeight), parentH, 0)
If setCam() = False Then
StatusString = "Errore nel set-up della WebCam"
End If
Else
StatusString = "WebCam già avviata"
End If
End Sub
Public Sub setFrameRate(ByVal iRate As Long)
Try
CamFrameRate = CInt(1000 / iRate)
resetCam()
Catch
StatusString = "Valore FPS errato!"
End Try
End Sub
Private Function setCam() As Boolean
Try
If SendMessage(hHwnd, WM_CAP_DRIVER_CONNECT, CShort(iDevice), CType(0, String)) = 1 Then
SendMessage(hHwnd, WM_CAP_SET_PREVIEWRATE, CShort(CamFrameRate), CType(0, String))
SendMessage(hHwnd, WM_CAP_SET_PREVIEW, 1, CType(0, String))
Me.iRunning = True
Return True
Else
Me.iRunning = False
Return False
End If
Catch
StatusString = "Errore impostazioni WebCam"
Return False
End Try
End Function
Public Sub CloseCam()
Try
If Me.iRunning Then
SendMessage(hHwnd, WM_CAP_DRIVER_DISCONNECT, 0, CType(0, String))
Me.iRunning = False
StatusString = "WebCam chiusa"
End If
Catch
StatusString = "Errore nella chiusura della WebCam"
End Try
End Sub
Public Function FPS() As Integer
Try
Return CInt(1000 / (CamFrameRate))
Catch
Return Nothing
End Try
End Function
Public Sub SaveFrame(ByVal FileName As String)
Try
SendMessage(hHwnd, WM_CAP_FILE_SAVEDIB, 0&, FileName)
StatusString = "Frame salvato con successo in "&FileName
Catch
StatusString = "Errore nel salvataggio del File"
End Try
End Sub
Public Function ConvertBMP(ByVal BMPFullPath As String, _
ByVal imgFormat As Imaging.ImageFormat) As Boolean
Dim Ans As Boolean
Dim sNewFile As String
Dim objBmp As New Bitmap(BMPFullPath)
Try
sNewFile = IO.Path.GetDirectoryName(BMPFullPath)
sNewFile &= IO.Path.GetFileNameWithoutExtension(BMPFullPath)
sNewFile &= "." & imgFormat.ToString
objBmp.Save(sNewFile, imgFormat)
StatusString = "Conversione effettuata con successo in "&sNewFile
PathString = IO.Path.GetDirectoryName(sNewFile)
Ans = True
Return Ans
Catch
StatusString = "Conversione fallita."
Ans = False
Return Ans
End Try
End Function
Public Sub StopVideo(ByVal FileName As String)
Try
If iRunning
SendMessage(hHWnd, WM_CAP_FILE_SAVEAS, 0,FileName)
StatusString = "Video fermato e salvato in "&FileName
End If
Catch
StatusString = "Impossibile salvare il Video"
End Try
End Sub
Public Sub RecordVideo()
Try
If iRunning
SendMessage(hHWnd, WM_CAP_SEQUENCE, 0, Nothing)
StatusString = "Video in registrazione..."
End If
Catch
StatusString = "Impossibile registrare il video!"
End Try
End Sub
End Class
