List and Select Sound Card to Play Sound - vb.net

I have a school bell project coded with Visual Basic 2010 Express. The computer which runs my program has two or more sound cards. First I will list the sound cards to user. User will select the sound card to work. Finally my program will ring the bells on that sound card. Everything is okey for my codes but i can't list the names of sound cards and ring the bell on specified sound card.
I use WMPLib to play music. I have these codes but there becomes an error "the value is not in the expected range". I spotted where the error is in my codes:
Public Declare Function waveOutGetNumDevs Lib "winmm" () As Integer
Public Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" (ByVal wDeviceID As Integer, ByVal uMessage As String, ByVal dwParam1 As Integer, ByVal dwParam2 As Object) As Integer
Public Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Integer, ByVal lpstrBuffer As String, ByVal uLength As Integer) As Integer
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
Public Declare Function mciGetDeviceID Lib "winmm.dll" Alias "mciGetDeviceIDA" (ByVal lpstrName As String) As Integer
Public Const MMSYSERR_NOERROR = 0
Public Const MCI_SET = &H80D
Public Const MCI_WAVE_OUTPUT = &H800000
Public Structure MCI_WAVE_SET_PARMS
Dim dwCallback As Integer
Dim dwTimeFormat As Integer
Dim dwAudio As Integer
Dim wInput As Integer
Dim wOutput As Integer
Dim wFormatTag As Short
Dim wReserved2 As Short
Dim nChannels As Short
Dim wReserved3 As Short
Dim nSamplesPerSec As Integer
Dim nAvgBytesPerSec As Integer
Dim nBlockAlign As Short
Dim wReserved4 As Short
Dim wBitsPerSample As Short
Dim wReserved5 As Short
End Structure
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
Dim parms As MCI_WAVE_SET_PARMS
Dim wDeviceID As Integer
Dim ret As Integer
parms.wOutput = 0
wDeviceID = mciGetDeviceID("waveaudio")
' the value is not in the expected range error is here and it spots parms
ret = mciSendCommand(wDeviceID, MCI_SET, MCI_WAVE_OUTPUT, parms)
If (ret <> MMSYSERR_NOERROR) Then
Stop
End If
If ofd.ShowDialog Then
ret = mciSendString("Open " & Chr(34) & ofd.FileName & Chr(34) & " alias audio", CStr(0), 0, 0)
ret = mciSendString("Open audio", CStr(0), 0, 0)
End If
End Sub

WindowsMedia.Net
You can do this using WindowsMedia.Net library.
The following example is taken from the link below, it is a code blonging to a Windows form and contains the functionality needed to list all available audio devices and choose the default device (the one that will act as sound output).
Set default Wave Out Audio Device - VB.Net / DRVM_MAPPER_PREFERRED_SET
First i will try to split the code into 2 parts:
List available audio devices
Change default audio device
List available devices
Private Sub RefreshInformation()
PopulateDeviceComboBox()
DisplayDefaultWaveOutDevice()
End Sub
Private Sub PopulateDeviceComboBox()
DevicesComboBox.Items.Clear()
' How many wave out devices are there? WaveOutGetNumDevs API call.
Dim waveOutDeviceCount As Integer = waveOut.GetNumDevs()
For i As Integer = 0 To waveOutDeviceCount - 1
Dim caps As New WaveOutCaps
' Get a name - its in a WAVEOUTCAPS structure.
' The name is truncated to 31 chars by the api call. You probably have to
' dig around in the registry to get the full name.
Dim result As Integer = waveOut.GetDevCaps(i, caps, Marshal.SizeOf(caps))
If result <> MMSYSERR.NoError Then
Dim err As MMSYSERR = DirectCast(result, MMSYSERR)
Throw New Win32Exception("GetDevCaps() error, Result: " & result.ToString("x8") & ", " & err.ToString)
End If
DevicesComboBox.Items.Add(New WaveOutDevice(i, caps))
Next
DevicesComboBox.SelectedIndex = 0
End Sub
Private Sub DisplayDefaultWaveOutDevice()
Dim currentDefault As Integer = GetIdOfDefaultWaveOutDevice()
Dim device As WaveOutDevice = DirectCast(DevicesComboBox.Items(currentDefault), WaveOutDevice)
DefaultDeviceLabel.Text = "Defualt: " & device.WaveOutCaps.szPname
End Sub
Private Function GetIdOfDefaultWaveOutDevice() As Integer
Dim id As Integer = 0
Dim hId As IntPtr
Dim flags As Integer = 0
Dim hFlags As IntPtr
Dim result As Integer
Try
' It would be easier to declare a nice overload with ByRef Integers.
hId = Marshal.AllocHGlobal(4)
hFlags = Marshal.AllocHGlobal(4)
' http://msdn.microsoft.com/en-us/library/bb981557.aspx
result = waveOut.Message(WAVE_MAPPER, DRVM_MAPPER_PREFERRED_GET, hId, hFlags)
If result <> MMSYSERR.NoError Then
Dim err As MMSYSERR = DirectCast(result, MMSYSERR)
Throw New Win32Exception("waveOutMessage() error, Result: " & result.ToString("x8") & ", " & err.ToString)
End If
id = Marshal.ReadInt32(hId)
flags = Marshal.ReadInt32(hFlags)
Finally
Marshal.FreeHGlobal(hId)
Marshal.FreeHGlobal(hFlags)
End Try
' There is only one flag, DRVM_MAPPER_PREFERRED_FLAGS_PREFERREDONLY, defined as 1
' "When the DRVM_MAPPER_PREFERRED_FLAGS_PREFERREDONLY flag bit is set, ... blah ...,
' the waveIn and waveOut APIs use only the current preferred device and do not search
' for other available devices if the preferred device is unavailable.
Return id
End Function
Change default device
Private Sub SetDefaultButton_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles SetDefaultButton.Click
If DevicesComboBox.Items.Count = 0 Then Return
Dim selectedDevice As WaveOutDevice = DirectCast(DevicesComboBox.SelectedItem, WaveOutDevice)
SetDefault(selectedDevice.Id)
RefreshInformation()
End Sub
Private Sub SetDefault(ByVal id As Integer)
Dim defaultId As Integer = GetIdOfDefaultWaveOutDevice()
If defaultId = id Then Return ' no change.
Dim result As Integer
' So here we say "change the Id of the device that has id id to 0", which makes it the default.
result = waveOut.Message(WAVE_MAPPER, DRVM_MAPPER_PREFERRED_SET, New IntPtr(id), IntPtr.Zero)
If result <> MMSYSERR.NoError Then
Dim err As MMSYSERR = DirectCast(result, MMSYSERR)
Throw New Win32Exception("waveOutMessage() error, Result: " & result.ToString("x8") & ", " & err.ToString)
End If
End Sub
Full code
Imports MultiMedia
Imports System.Runtime.InteropServices
Imports System.ComponentModel
Public Class Form1
Private DevicesComboBox As New ComboBox
Private DefaultDeviceLabel As New Label
Private WithEvents SetDefaultButton As New Button
Private Const DRVM_MAPPER_PREFERRED_GET As Integer = &H2015
Private Const DRVM_MAPPER_PREFERRED_SET As Integer = &H2016
Private WAVE_MAPPER As New IntPtr(-1)
' This just brings together a device ID and a WaveOutCaps so
' that we can store them in a combobox.
Private Structure WaveOutDevice
Private m_id As Integer
Public Property Id() As Integer
Get
Return m_id
End Get
Set(ByVal value As Integer)
m_id = value
End Set
End Property
Private m_caps As WaveOutCaps
Public Property WaveOutCaps() As WaveOutCaps
Get
Return m_caps
End Get
Set(ByVal value As WaveOutCaps)
m_caps = value
End Set
End Property
Sub New(ByVal id As Integer, ByVal caps As WaveOutCaps)
m_id = id
m_caps = caps
End Sub
Public Overrides Function ToString() As String
Return WaveOutCaps.szPname
End Function
End Structure
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
' I do use the IDE for this stuff normally... (in case anyone is wondering)
Me.Controls.AddRange(New Control() {DevicesComboBox, DefaultDeviceLabel, SetDefaultButton})
DevicesComboBox.Location = New Point(5, 5)
DevicesComboBox.DropDownStyle = ComboBoxStyle.DropDownList
DevicesComboBox.Width = Me.ClientSize.Width - 10
DevicesComboBox.Anchor = AnchorStyles.Left Or AnchorStyles.Right
DefaultDeviceLabel.Location = New Point(DevicesComboBox.Left, DevicesComboBox.Bottom + 5)
DefaultDeviceLabel.AutoSize = True
SetDefaultButton.Location = New Point(DefaultDeviceLabel.Left, DefaultDeviceLabel.Bottom + 5)
SetDefaultButton.Text = "Set Default"
SetDefaultButton.AutoSize = True
RefreshInformation()
End Sub
Private Sub RefreshInformation()
PopulateDeviceComboBox()
DisplayDefaultWaveOutDevice()
End Sub
Private Sub PopulateDeviceComboBox()
DevicesComboBox.Items.Clear()
' How many wave out devices are there? WaveOutGetNumDevs API call.
Dim waveOutDeviceCount As Integer = waveOut.GetNumDevs()
For i As Integer = 0 To waveOutDeviceCount - 1
Dim caps As New WaveOutCaps
' Get a name - its in a WAVEOUTCAPS structure.
' The name is truncated to 31 chars by the api call. You probably have to
' dig around in the registry to get the full name.
Dim result As Integer = waveOut.GetDevCaps(i, caps, Marshal.SizeOf(caps))
If result <> MMSYSERR.NoError Then
Dim err As MMSYSERR = DirectCast(result, MMSYSERR)
Throw New Win32Exception("GetDevCaps() error, Result: " & result.ToString("x8") & ", " & err.ToString)
End If
DevicesComboBox.Items.Add(New WaveOutDevice(i, caps))
Next
DevicesComboBox.SelectedIndex = 0
End Sub
Private Sub DisplayDefaultWaveOutDevice()
Dim currentDefault As Integer = GetIdOfDefaultWaveOutDevice()
Dim device As WaveOutDevice = DirectCast(DevicesComboBox.Items(currentDefault), WaveOutDevice)
DefaultDeviceLabel.Text = "Defualt: " & device.WaveOutCaps.szPname
End Sub
Private Function GetIdOfDefaultWaveOutDevice() As Integer
Dim id As Integer = 0
Dim hId As IntPtr
Dim flags As Integer = 0
Dim hFlags As IntPtr
Dim result As Integer
Try
' It would be easier to declare a nice overload with ByRef Integers.
hId = Marshal.AllocHGlobal(4)
hFlags = Marshal.AllocHGlobal(4)
' http://msdn.microsoft.com/en-us/library/bb981557.aspx
result = waveOut.Message(WAVE_MAPPER, DRVM_MAPPER_PREFERRED_GET, hId, hFlags)
If result <> MMSYSERR.NoError Then
Dim err As MMSYSERR = DirectCast(result, MMSYSERR)
Throw New Win32Exception("waveOutMessage() error, Result: " & result.ToString("x8") & ", " & err.ToString)
End If
id = Marshal.ReadInt32(hId)
flags = Marshal.ReadInt32(hFlags)
Finally
Marshal.FreeHGlobal(hId)
Marshal.FreeHGlobal(hFlags)
End Try
' There is only one flag, DRVM_MAPPER_PREFERRED_FLAGS_PREFERREDONLY, defined as 1
' "When the DRVM_MAPPER_PREFERRED_FLAGS_PREFERREDONLY flag bit is set, ... blah ...,
' the waveIn and waveOut APIs use only the current preferred device and do not search
' for other available devices if the preferred device is unavailable.
Return id
End Function
Private Sub SetDefaultButton_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles SetDefaultButton.Click
If DevicesComboBox.Items.Count = 0 Then Return
Dim selectedDevice As WaveOutDevice = DirectCast(DevicesComboBox.SelectedItem, WaveOutDevice)
SetDefault(selectedDevice.Id)
RefreshInformation()
End Sub
Private Sub SetDefault(ByVal id As Integer)
Dim defaultId As Integer = GetIdOfDefaultWaveOutDevice()
If defaultId = id Then Return ' no change.
Dim result As Integer
' So here we say "change the Id of the device that has id id to 0", which makes it the default.
result = waveOut.Message(WAVE_MAPPER, DRVM_MAPPER_PREFERRED_SET, New IntPtr(id), IntPtr.Zero)
If result <> MMSYSERR.NoError Then
Dim err As MMSYSERR = DirectCast(result, MMSYSERR)
Throw New Win32Exception("waveOutMessage() error, Result: " & result.ToString("x8") & ", " & err.ToString)
End If
End Sub
End Class
System.Management
You can retrieve the available audio devices using System.Management assembly which is a part of .Net framework:
ManagementObjectSearcher mo =
new ManagementObjectSearcher("select * from Win32_SoundDevice");
foreach (ManagementObject soundDevice in mo.Get())
{
String deviceId = soundDevice.GetPropertyValue("DeviceId").ToString();
String name = soundDevice.GetPropertyValue("Name").ToString();
//saving the name and device id in array
}
References
Get list of audio devices and select one using c# (Another solution provided in this link (using Lync 2013 SDK)
Win32_SoundDevice class

Related

Set icon from generated exe in VB.NET

I'm trying to set the icon from a generated Windows Form Application, here's my code.
Private Sub CompileSourceCode()
Dim cProvider As CodeDomProvider = New VBCodeProvider
Dim cParams As New CompilerParameters
Dim cResult As CompilerResults
Dim sourceCode As String = generate_exe.final_winform
With cParams
.GenerateInMemory = False
.GenerateExecutable = True
.OutputAssembly = "test.exe"
.CompilerOptions = "/target:winexe /win32icon:eye.ico"
.ReferencedAssemblies.AddRange({"System.dll", "System.Windows.Forms.dll", "Microsoft.VisualBasic.dll"})
.MainClass = "MyNamespace.form1"
End With
cResult = cProvider.CompileAssemblyFromSource(cParams, sourceCode)
cProvider.Dispose()
If cResult.Errors.HasErrors Then
MsgBox(cResult.Errors(0).Line.ToString & ", " & cResult.Errors(0).ErrorText)
End If
End Sub
The problem:
The first time i run it, it creates the EXE with the icon i chose.
The second time, if i just change the icon i want to use but leave it as the same OutputAssembly name (test.exe) it creates the EXE but with the old icon, doesn't update.
Edit: Found a very good solution, Although It's been a long time since my question, I think it could help someone else with the same problem using SHChangeNotify. Add that to the top of the code:
Const SHCNE_ASSOCCHANGED As Integer = &H8000000
Const SHCNF_IDLIST As Integer = 0
Private Class NativeMethods
<DllImport("shell32")>
Public Shared Sub SHChangeNotify(ByVal wEventId As Integer, ByVal flags As Integer, ByVal item1 As IntPtr, ByVal item2 As IntPtr)
End Sub
End Class
Usage: (before or after your compile command)
NativeMethods.SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, Nothing, Nothing)

Replicate Windows Unhide folders and files function

I'm re-visiting a tool that I wrote in VB.Net for my helpdesk team a while back and want to add a couple of checkboxes to replicate the same function that Windows uses to show hidden files and folders / re-hide, as well as protected operating system files.
I know I can do this by editing a registry entry and restarting explorer.exe, but that closes all open Explorer Windows and I don't want that.
Does anyone know how Windows is able to do this by a simple click of a checkbox and how I may be able to code it in VB.net?
Any input on this is greatly appreciated in advance.
EDIT: So it looks like I have found a refresh method that works to refresh Windows Explorer / File Explorer which can be applied to Drarig's answer below but I am having trouble converting it to VB.net as the original example is in C#.
'Original at http://stackoverflow.com/questions/2488727/refresh-windows-explorer-in-win7
Private Sub refreshExplorer(ByVal explorerType As String)
Dim CLSID_ShellApplication As Guid = Guid.Parse("13709620-C279-11CE-A49E-444553540000")
Dim shellApplicationType As Type = Type.GetTypeFromCLSID(CLSID_ShellApplication, True)
Dim shellApplication As Object = Activator.CreateInstance(shellApplicationType)
Dim windows As Object = shellApplicationType.InvokeMember("Windows", Reflection.BindingFlags.InvokeMethod, Nothing, shellApplication, New Object() {})
Dim windowsType As Type = windows.GetType()
Dim count As Object = windowsType.InvokeMember("Count", Reflection.BindingFlags.GetProperty, Nothing, windows, Nothing)
For i As Integer = 0 To CType(count, Integer)
Dim item As Object = windowsType.InvokeMember("Item", Reflection.BindingFlags.InvokeMethod, Nothing, windows, New Object() {i})
Dim itemType As Type = item.GetType()
'Only fresh Windows explorer Windows
Dim itemName As String = CType(itemType.InvokeMember("Name", Reflection.BindingFlags.GetProperty, Nothing, item, Nothing), String)
If itemName = explorerType Then
itemType.InvokeMember("Refresh", Reflection.BindingFlags.InvokeMethod, Nothing, item, Nothing)
End If
Next
End Sub
I am getting an exception Object reference not set to an instance of an object when I set itemType as Type = item.GetType() above. I can't figure out which object isn't being created. When I step through the code it looks like windowsType contains an object for windows. Does anyone have any idea on this? Once this is worked out I can then apply it to Drarig's solution below.
Alright I wish I could have got this to you sooner, but busy lately at work. I took a little time today to figure this out as I love digging into something I have not done before. This is the whole class from a new project; didn't have time to wrap it up in a separate class. I am sure this will get you what you need. It was a little harder than I thought as getting the correct handle and then send the command, but I got it. I hope you find it useful.
P.S. Some of the things you can leave out, specifically the boolean used for loading, this was so I can pull the current value back on load and either check/uncheck the CheckBox.
Note: This is tried and tested on Windows 7, 8 and 10
Imports Microsoft.Win32
Imports System.Reflection
Imports System.Runtime.InteropServices
Public Class Form1
<Flags()> _
Public Enum KeyboardFlag As UInteger
KEYBOARDF_5 = &H74
End Enum
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function GetWindow(ByVal hl As Long, ByVal vm As Long) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function PostMessage(ByVal hWnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Boolean
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Private Shared Function FindWindow(ByVal lpClassName As String, ByVal lpWindowName As String) As IntPtr
End Function
Private blnLoading As Boolean = False
Private Sub CheckBox1_CheckedChanged(sender As Object, e As EventArgs) Handles CheckBox1.CheckedChanged
Form1.HideFilesExtension(Me.CheckBox1.Checked)
If Not blnLoading Then NotifyFileAssociationChanged()
RefreshExplorer()
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Dim name As String = "Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced"
Dim key As RegistryKey = Registry.CurrentUser.OpenSubKey(name, False)
blnLoading = True
Me.CheckBox1.Checked = CBool(key.GetValue("Hidden"))
key.Close()
blnLoading = False
End Sub
Private Shared Sub HideFilesExtension(ByVal Hide As Boolean)
Dim name As String = "Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced"
Dim key As RegistryKey = Registry.CurrentUser.OpenSubKey(name, True)
key.SetValue("Hidden", If(Hide, 1, 0))
key.Close()
End Sub
Public Shared Sub RefreshExplorer()
Dim clsid As New Guid("13709620-C279-11CE-A49E-444553540000")
Dim typeFromCLSID As Type = Type.GetTypeFromCLSID(clsid, True)
Dim objectValue As Object = Activator.CreateInstance(typeFromCLSID)
Dim obj4 As Object = typeFromCLSID.InvokeMember("Windows", BindingFlags.InvokeMethod, Nothing, objectValue, New Object(0 - 1) {})
Dim type1 As Type = obj4.GetType
Dim obj2 As Object = type1.InvokeMember("Count", BindingFlags.GetProperty, Nothing, obj4, Nothing)
If (CInt(obj2) <> 0) Then
Dim num2 As Integer = (CInt(obj2) - 1)
Dim i As Integer = 0
Do While (i <= num2)
Dim obj5 As Object = type1.InvokeMember("Item", BindingFlags.InvokeMethod, Nothing, obj4, New Object() {i})
Dim type3 As Type = obj5.GetType
Dim str As String = CStr(type3.InvokeMember("Name", BindingFlags.GetProperty, Nothing, obj5, Nothing))
If (str = "File Explorer") Then
type3.InvokeMember("Refresh", BindingFlags.InvokeMethod, Nothing, obj5, Nothing)
End If
i += 1
Loop
End If
End Sub
Public Shared Sub NotifyFileAssociationChanged()
'Find the actual window...
Dim hwnd As IntPtr = FindWindow("Progman", "Program Manager")
'Get the window handle and refresh option...
Dim j = GetWindow(hwnd, 3)
'Finally post the message...
PostMessage(j, 256, KeyboardFlag.KEYBOARDF_5, 3)
End Sub
End Class
Here's a solution for everything excepting the refreshing of the explorer.
I've translated the code, but I'm unable to find how to refresh the explorer/desktop without restarting it.
Const keyName As String = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced"
Const Hidden As String = "Hidden"
Const SHidden As String = "ShowSuperHidden"
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim St As Integer = GetRegValue(Hidden)
If St = 2 Then
SetRegValue(Hidden, 1)
SetRegValue(SHidden, 1)
Else
SetRegValue(Hidden, 2)
SetRegValue(SHidden, 0)
End If
End Sub
Private Function GetRegValue(valueName As String) As Integer
Return CInt(My.Computer.Registry.GetValue(keyName, valueName, 0))
End Function
Private Sub SetRegValue(valueName As String, value As Integer)
My.Computer.Registry.SetValue(keyName, valueName, value, Microsoft.Win32.RegistryValueKind.DWord)
End Sub
I have a few ideas to refresh the desktop :
Send a key to a running process. I tried this (source) :
Dim pp As Process() = Process.GetProcessesByName("explorer")
If pp.Length > 0 Then
For Each p In pp
AppActivate(p.Id)
SendKeys.SendWait("{F5}")
Next
End If
Refresh using SHChangeNotify (source),
Refresh broadcasting a WM_SETTINGCHANGE message (source),
etc.
I think you'll be forced to manually refresh or restart the explorer.

How to get the information in the console to a textbox

I'm writing a code using vb.net that can get some information from a radar sensor connected to the computer through a device called CANcaseXL ,, I added the dll file reference corresponding to the CANcaseXL driver and in the manual there is a command that let me print the information that goes to the CANcaseXL to the console (the command is xlPrintRx(XLClass.xl_event receivedEvent)) and its a continuous real-time data going from the radar to the computer through the CANcaseXL.
Now I can see the data in the console but I need to extract it like print it to a textbox maybe then do the calculations but I don't know how.
I will appreciate any help !
this like the main code I have been working on, I got most of it using the XL Driver Library - .NET Wrapper Description >> http://www.labviewforum.de/attachment.php?aid=43764 and a ready made application.
Option Explicit On
Imports System
Imports System.Runtime.InteropServices
Imports System.Threading
Imports vxlapi_NET20
Imports System.IO
Public Class Main
Region "DLL_Import"
<DllImport("kernel32.dll", SetLastError:=True)> _
Shared Function WaitForSingleObject(ByVal handle As Integer, ByVal timeOut As Integer) As Integer
End Function
End Region
Region "GLOBALS"
Shared CANDemo_TxChannel As xlSingleChannelCAN_Port
Shared CANDemo_RxChannel As xlSingleChannelCAN_Port
Private RxThread As Thread
Private Enum WaitResults : int
WAIT_ABANDONED = &H80
WAIT_FAILED = &HFFFFFFF
WAIT_OBJECT_0 = &H0
WAIT_TIMEOUT = &H102
INFINITE = &HFFFF
End Enum
End Region
Declare Function AllocConsole Lib "kernel32" () As Int32
Declare Function FreeConsole Lib "kernel32" () As Int32
Public Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
AllocConsole()
ProgressBar1.Value = 0
Dim Max As Double
Dim Min As Double
Dim id As String
Dim dlc As String
Dim data As String
Max = Val(TextBox1.Text)
Min = Val(TextBox2.Text)
id = Val(TextBox3.Text)
dlc = Val(TextBox4.Text)
data = TextBox5.Text
If data = "" Then
data = 0
End If
Dim Max_hex As Double = Val("&H" & Max)
Dim Min_hex As Double = Val("&H" & Min)
If (Max < 1 Or Min < 0) Then
MsgBox("Please fill the range fields!!", MsgBoxStyle.Critical)
GoTo C
End If
CANDemo_TxChannel = New xlSingleChannelCAN_Port("xlCANdemo NET", Convert.ToUInt32(0))
CANDemo_RxChannel = New xlSingleChannelCAN_Port("xlCANdemo NET", Convert.ToUInt32(0))
If (CANDemo_TxChannel.xlCheckPort() And CANDemo_RxChannel.xlCheckPort()) Then
Label10.BackColor = Color.Green
Label11.Text = "CAN Connected ..."
' these two commands print the configuration for the CANcaseXL device
CANDemo_TxChannel.xlPrintConfig()
CANDemo_RxChannel.xlPrintConfig()
CANDemo_RxChannel.xlResetAcceptanceFilter()
CANDemo_RxChannel.xlCanAddAcceptanceRange(Convert.ToUInt32(Min_hex), Convert.ToUInt32(Max_hex))
CANDemo_TxChannel.xlActivate()
CANDemo_RxChannel.xlActivate()
Dim RxThread As New Thread(AddressOf RX_Thread)
RxThread.Start()
If MsgBox("Are you sure you wont to transmit ?", MsgBoxStyle.YesNo, "Transmission") = MsgBoxResult.Yes Then
CANDemo_TxChannel.xlTransmit(Convert.ToUInt32(id, 16), Convert.ToUInt16(dlc, 16), Convert.ToUInt64(data, 16))
ProgressBar1.Value = 100
MsgBox("Data Transmited!", MsgBoxStyle.Information, "Transmission")
Else
End If
Else
Label10.BackColor = Color.Red
Label11.Text = "CAN Disconnected!!"
MsgBox("Check the device connection!", MsgBoxStyle.Critical, "CAN disconnected")
CANDemo_TxChannel.xlClosePort()
CANDemo_RxChannel.xlClosePort()
End If
C:
End Sub
Region "EVENT THREAD (RX)"
Public Shared Sub RX_Thread()
Dim receivedEvent As XLClass.xl_event = New XLClass.xl_event
Dim xlStatus As XLClass.XLstatus = XLClass.XLstatus.XL_SUCCESS
Dim waitResult As WaitResults
While (True)
waitResult = WaitForSingleObject(CANDemo_RxChannel.eventHandle, 1000)
If (waitResult <> WaitResults.WAIT_TIMEOUT) Then
xlStatus = XLClass.XLstatus.XL_SUCCESS
While (xlStatus <> XLClass.XLstatus.XL_ERR_QUEUE_IS_EMPTY)
xlStatus = CANDemo_RxChannel.xlReceive(receivedEvent)
If (xlStatus = XLClass.XLstatus.XL_SUCCESS) Then
' this command let the coming results from the Radar printed to the console
CANDemo_RxChannel.xlPrintRx(receivedEvent)
End If
End While
End If
End While
End Sub
End Region

sending binary a type variable (struct) over serial port

Is it possible at VB6 to send whole contents of a type (struct) over serial port ?
The following example doesnt works.
Private Type CommFrameStruct
node As String
Inputs As Byte
Outputs As Byte
End Type
at form load...
Dim msg As CommFrameStruct
msg.node = "TEST"
msg.Inputs = 5
msg.Outputs = 2
MSComm1.PortOpen = True
MSComm1.Output = msg
You have to set the InputMode property of the MSComm control to comInputModeBinary
You can then convert your UDT to an raay of bytes and send that
Two quick example projects :
One project to send the UDT :
' form with :
' 1 command button: name=Command1
' 1 MSComm control: name=MSComm1
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type CommFrameStruct
node As String * 10
Inputs As Byte
Outputs As Byte
End Type
Private Sub Command1_Click()
Dim msg As CommFrameStruct
Dim bytArr() As Byte
msg.node = "TEST"
msg.Inputs = 5
msg.Outputs = 2
ReDim bytArr(Len(msg) - 1) As Byte
CopyMemory bytArr(0), msg, Len(msg)
MSComm1.Output = bytArr
End Sub
Private Sub Form_Load()
With MSComm1
.InputMode = comInputModeBinary
.Settings = "115200,N,8,1"
.PortOpen = True
End With 'MSCOmm1
End Sub
And one project to receive the UDT :
'1 form with :
' 1 Textbox control: name=Text1 multiline=true
' 1 MSComm control : name=MSComm1
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Type CommFrameStruct
node As String * 10
Inputs As Byte
Outputs As Byte
End Type
Private mudtMsg As CommFrameStruct
Private Sub Form_Load()
With MSComm1
.InputMode = comInputModeBinary
.RThreshold = Len(mudtMsg)
.Settings = "115200,N,8,1"
.PortOpen = True
End With 'MSComm1
End Sub
Private Sub Form_Resize()
Text1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub MSComm1_OnComm()
Dim lngIndex As Long
Dim bytArr() As Byte
With MSComm1
Select Case .CommEvent
Case comEvReceive
bytArr = .Input
For lngIndex = 0 To UBound(bytArr)
ShowText "Byte " & CStr(lngIndex) & " : " & CStr(bytArr(lngIndex))
Next lngIndex
CopyMemory mudtMsg, bytArr(0), Len(mudtMsg)
ShowText "Node: " & mudtMsg.node
ShowText "Inputs: " & mudtMsg.Inputs
ShowText "Outputs: " & mudtMsg.Outputs
End Select
End With 'MSComm1
End Sub
Private Sub ShowText(strText As String)
Text1.SelText = vbCrLf & strText
End Sub
There are probably more elegant ways (especially for converting the UDT to byte-array and back), but this seems to work :)

VB.Net Directshow Webcam Snapshot

I am new to stackoverflow but I registered because I think here is the right place to get professional help for programming :)
My goal is to create a webcam snapshot tool which directly saves the snapshot to a file.
I don't need any preview in a picturebox or something like that.
I am thinking about a application like this:
A simple Interface with a Combobox for the connected webcam devices and one button which will take a snapshot and saves it to a file.
I like to use DirectShow for this because all other ways using AForge or advcap32.dll, because they sometimes cause
a Videosourcedialog to popup, which I don't want to.
I like to select a webcamdevice in my combobox manually and be able to take a snapshot.
So that way I like to use DirectShow.
I already added the DirectShowLib-2005.dll to my VB.Net Project
And I also added this class:
Imports System
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Imports System.Diagnostics
Imports DirectShowLib
Public Class Capture
Implements ISampleGrabberCB
Implements IDisposable
#Region "Member variables"
Private m_graphBuilder As IFilterGraph2 = Nothing
Private m_mediaCtrl As IMediaControl = Nothing
Private mediaEventEx As IMediaEventEx = Nothing
Private videoWindow As IVideoWindow = Nothing
Private UseHand As IntPtr = MainForm.PictureBox1.Handle
Private Const WMGraphNotify As Integer = 13
Private m_takePicture As Boolean = False
Public mytest As String = "yes"
Dim sampGrabber As ISampleGrabber = Nothing
Private bufferedSize As Integer = 0
Private savedArray() As Byte
Public capturedPic As bitmap
Public captureSaved As Boolean
Public unsupportedVideo As Boolean
' <summary> Set by async routine when it captures an image </summary>
Public m_bRunning As Boolean = False
' <summary> Dimensions of the image, calculated once in constructor. </summary>
Private m_videoWidth As Integer
Private m_videoHeight As Integer
Private m_stride As Integer
Private m_bmdLogo As BitmapData = Nothing
Private m_Bitmap As Bitmap = Nothing
#If DEBUG Then
' Allow you to "Connect to remote graph" from GraphEdit
Private m_rot As DsROTEntry = Nothing
#End If
#End Region
#Region "API"
Declare Sub CopyMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As IntPtr, ByVal Source As IntPtr, <MarshalAs(UnmanagedType.U4)> ByVal Length As Integer)
#End Region
' zero based device index, and some device parms, plus the file name to save to
Public Sub New(ByVal iDeviceNum As Integer, ByVal iFrameRate As Integer, ByVal iWidth As Integer, ByVal iHeight As Integer)
Dim capDevices As DsDevice()
' Get the collection of video devices
capDevices = DsDevice.GetDevicesOfCat(FilterCategory.VideoInputDevice)
If (iDeviceNum + 1 > capDevices.Length) Then
Throw New Exception("No video capture devices found at that index!")
End If
Dim dev As DsDevice = capDevices(iDeviceNum)
Try
' Set up the capture graph
SetupGraph(dev, iFrameRate, iWidth, iHeight)
Catch
Dispose()
If unsupportedVideo Then
msgbox("This video resolution isn't supported by the camera - please choose a different resolution.")
Else
Throw
End If
End Try
End Sub
' <summary> release everything. </summary>
Public Sub Dispose() Implements IDisposable.Dispose
CloseInterfaces()
If (Not m_Bitmap Is Nothing) Then
m_Bitmap.UnlockBits(m_bmdLogo)
m_Bitmap = Nothing
m_bmdLogo = Nothing
End If
End Sub
Protected Overloads Overrides Sub finalize()
CloseInterfaces()
End Sub
' <summary> capture the next image </summary>
Public Sub Start()
If (m_bRunning = False) Then
Dim hr As Integer = m_mediaCtrl.Run()
DsError.ThrowExceptionForHR(hr)
m_bRunning = True
End If
End Sub
' Pause the capture graph.
' Running the graph takes up a lot of resources. Pause it when it
' isn't needed.
Public Sub Pause()
If (m_bRunning) Then
Dim hr As Integer = m_mediaCtrl.Pause()
DsError.ThrowExceptionForHR(hr)
m_bRunning = False
End If
End Sub
'Added by jk
Public Sub TakePicture()
m_takePicture = True
End Sub
' <summary> Specify the logo file to write onto each frame </summary>
Public Sub SetLogo(ByVal fileName As String)
SyncLock Me
If (fileName.Length > 0) Then
m_Bitmap = New Bitmap(fileName)
Dim r As Rectangle = New Rectangle(0, 0, m_Bitmap.Width, m_Bitmap.Height)
m_bmdLogo = m_Bitmap.LockBits(r, ImageLockMode.ReadWrite, PixelFormat.Format24bppRgb)
Else
If Not m_Bitmap Is Nothing Then
m_Bitmap.UnlockBits(m_bmdLogo)
m_Bitmap = Nothing
m_bmdLogo = Nothing
End If
End If
End SyncLock
End Sub
' <summary> build the capture graph for grabber. </summary>
Private Sub SetupGraph(ByVal dev As DsDevice, ByVal iFrameRate As Integer, ByVal iWidth As Integer, ByVal iHeight As Integer)
Dim hr As Integer
Dim baseGrabFlt As IBaseFilter = Nothing
Dim capFilter As IBaseFilter = Nothing
Dim muxFilter As IBaseFilter = Nothing
Dim fileWriterFilter As IFileSinkFilter = Nothing
Dim capGraph As ICaptureGraphBuilder2 = Nothing
Dim sampGrabberSnap As ISampleGrabber = Nothing
' Get the graphbuilder object
m_graphBuilder = DirectCast(New FilterGraph(), IFilterGraph2)
m_mediaCtrl = DirectCast(m_graphBuilder, IMediaControl)
'if taking a picture (a still snapshot), then remove the videowindow
If Not m_takePicture Then
mediaEventEx = DirectCast(m_graphBuilder, IMediaEventEx)
videoWindow = DirectCast(m_graphBuilder, IVideoWindow)
Else
mediaEventEx = Nothing
videoWindow = Nothing
End If
#If DEBUG Then
m_rot = New DsROTEntry(m_graphBuilder)
#End If
Try
' Get the ICaptureGraphBuilder2
capGraph = DirectCast(New CaptureGraphBuilder2(), ICaptureGraphBuilder2)
' Get the SampleGrabber interface
sampGrabber = DirectCast(New SampleGrabber(), ISampleGrabber)
sampGrabberSnap = DirectCast(New SampleGrabber(), ISampleGrabber)
' Start building the graph
hr = capGraph.SetFiltergraph(DirectCast(m_graphBuilder, IGraphBuilder))
DsError.ThrowExceptionForHR(hr)
' Add the video device
hr = m_graphBuilder.AddSourceFilterForMoniker(dev.Mon, Nothing, dev.Name, capFilter)
DsError.ThrowExceptionForHR(hr)
baseGrabFlt = DirectCast(sampGrabber, IBaseFilter)
ConfigureSampleGrabber(sampGrabber)
' Add the frame grabber to the graph
hr = m_graphBuilder.AddFilter(baseGrabFlt, "Ds.NET Grabber")
DsError.ThrowExceptionForHR(hr)
' If any of the default config items are set
If (iFrameRate + iHeight + iWidth > 0) Then
SetConfigParms(capGraph, capFilter, iFrameRate, iWidth, iHeight)
End If
hr = capGraph.RenderStream(PinCategory.Capture, MediaType.Video, capFilter, baseGrabFlt, muxFilter)
DsError.ThrowExceptionForHR(hr)
'if you set the m_takePicture it won't
If Not m_takePicture Then
'Set the output of the preview
hr = mediaEventEx.SetNotifyWindow(UseHand, WMGraphNotify, IntPtr.Zero)
DsError.ThrowExceptionForHR(hr)
'Set Owner to Display Video
hr = videoWindow.put_Owner(UseHand)
DsError.ThrowExceptionForHR(hr)
'Set window location - this was necessary so that the video didn't move down and to the right when you pushed the start/stop button
hr = videoWindow.SetWindowPosition(0, 0, 320, 240)
DsError.ThrowExceptionForHR(hr)
'Set Owner Video Style
hr = videoWindow.put_WindowStyle(WindowStyle.Child)
DsError.ThrowExceptionForHR(hr)
End If
SaveSizeInfo(sampGrabber)
Finally
If (Not fileWriterFilter Is Nothing) Then
Marshal.ReleaseComObject(fileWriterFilter)
fileWriterFilter = Nothing
End If
If (Not muxFilter Is Nothing) Then
Marshal.ReleaseComObject(muxFilter)
muxFilter = Nothing
End If
If (Not capFilter Is Nothing) Then
Marshal.ReleaseComObject(capFilter)
capFilter = Nothing
End If
If (Not sampGrabber Is Nothing) Then
Marshal.ReleaseComObject(sampGrabber)
sampGrabber = Nothing
End If
End Try
End Sub
' <summary> Read and store the properties </summary>
Private Sub SaveSizeInfo(ByVal sampGrabber As ISampleGrabber)
Dim hr As Integer
' Get the media type from the SampleGrabber
Dim media As AMMediaType = New AMMediaType()
hr = sampGrabber.GetConnectedMediaType(media)
DsError.ThrowExceptionForHR(hr)
If (Not (media.formatType.Equals(FormatType.VideoInfo)) AndAlso Not (media.formatPtr.Equals(IntPtr.Zero))) Then
Throw New NotSupportedException("Unknown Grabber Media Format")
End If
' Grab the size info
Dim vInfoHeader As VideoInfoHeader = New VideoInfoHeader()
Marshal.PtrToStructure(media.formatPtr, vInfoHeader)
m_videoWidth = vInfoHeader.BmiHeader.Width
m_videoHeight = vInfoHeader.BmiHeader.Height
m_stride = CInt(m_videoWidth * (vInfoHeader.BmiHeader.BitCount / 8))
DsUtils.FreeAMMediaType(media)
media = Nothing
End Sub
' <summary> Set the options on the sample grabber </summary>
Private Sub ConfigureSampleGrabber(ByVal sampGrabber As ISampleGrabber)
Dim hr As Integer
Dim media As AMMediaType = New AMMediaType()
media.majorType = MediaType.Video
media.subType = MediaSubType.RGB24
media.formatType = FormatType.VideoInfo
hr = sampGrabber.SetMediaType(media)
DsError.ThrowExceptionForHR(hr)
DsUtils.FreeAMMediaType(media)
media = Nothing
' Configure the samplegrabber callback
hr = sampGrabber.SetOneShot(False)
DsError.ThrowExceptionForHR(hr)
If m_takePicture Then
hr = sampGrabber.SetCallback(Me, 0)
Else
hr = sampGrabber.SetCallback(Me, 0)
End If
DsError.ThrowExceptionForHR(hr)
DsError.ThrowExceptionForHR(hr)
'set the samplegrabber
sampGrabber.SetBufferSamples(False)
End Sub
' Set the Framerate, and video size
Private Sub SetConfigParms(ByVal capGraph As ICaptureGraphBuilder2, ByVal capFilter As IBaseFilter, ByVal iFrameRate As Integer, ByVal iWidth As Integer, ByVal iHeight As Integer)
Dim hr As Integer
Dim o As Object = Nothing
Dim media As AMMediaType = Nothing
Dim videoStreamConfig As IAMStreamConfig
Dim videoControl As IAMVideoControl = DirectCast(capFilter, IAMVideoControl)
' Find the stream config interface
hr = capGraph.FindInterface(PinCategory.Capture, MediaType.Video, capFilter, GetType(IAMStreamConfig).GUID, o)
videoStreamConfig = DirectCast(o, IAMStreamConfig)
Try
If (videoStreamConfig Is Nothing) Then
Throw New Exception("Failed to get IAMStreamConfig")
End If
' Get the existing format block
hr = videoStreamConfig.GetFormat(media)
DsError.ThrowExceptionForHR(hr)
' copy out the videoinfoheader
Dim v As VideoInfoHeader = New VideoInfoHeader()
Marshal.PtrToStructure(media.formatPtr, v)
' if overriding the framerate, set the frame rate
If (iFrameRate > 0) Then
v.AvgTimePerFrame = CLng(10000000 / iFrameRate)
End If
' if overriding the width, set the width
If (iWidth > 0) Then
v.BmiHeader.Width = iWidth
End If
' if overriding the Height, set the Height
If (iHeight > 0) Then
v.BmiHeader.Height = iHeight
End If
' Copy the media structure back
Marshal.StructureToPtr(v, media.formatPtr, False)
' Set the new format
hr = videoStreamConfig.SetFormat(media)
If hr <> 0 Then unsupportedVideo = True Else unsupportedVideo = False
DsError.ThrowExceptionForHR(hr)
DsUtils.FreeAMMediaType(media)
media = Nothing
' Fix upsidedown video
If (Not videoControl Is Nothing) Then
Dim pCapsFlags As VideoControlFlags
Dim pPin As IPin = DsFindPin.ByCategory(capFilter, PinCategory.Capture, 0)
hr = videoControl.GetCaps(pPin, pCapsFlags)
DsError.ThrowExceptionForHR(hr)
If (CDbl(pCapsFlags & VideoControlFlags.FlipVertical) > 0) Then
hr = videoControl.GetMode(pPin, pCapsFlags)
DsError.ThrowExceptionForHR(hr)
hr = videoControl.SetMode(pPin, 0)
End If
End If
Finally
Marshal.ReleaseComObject(videoStreamConfig)
End Try
End Sub
' <summary> Shut down capture </summary>
Private Sub CloseInterfaces()
Dim hr As Integer
Try
If (Not m_mediaCtrl Is Nothing) Then
' Stop the graph
hr = m_mediaCtrl.Stop()
m_mediaCtrl = Nothing
m_bRunning = False
'Release Window Handle, Reset back to Normal
hr = videoWindow.put_Visible(OABool.False)
DsError.ThrowExceptionForHR(hr)
hr = videoWindow.put_Owner(IntPtr.Zero)
DsError.ThrowExceptionForHR(hr)
If mediaEventEx Is Nothing = False Then
hr = mediaEventEx.SetNotifyWindow(IntPtr.Zero, 0, IntPtr.Zero)
DsError.ThrowExceptionForHR(hr)
End If
End If
Catch ex As Exception
Debug.WriteLine(ex)
End Try
#If DEBUG Then
If (Not m_rot Is Nothing) Then
m_rot.Dispose()
m_rot = Nothing
End If
#End If
If (Not m_graphBuilder Is Nothing) Then
Marshal.ReleaseComObject(m_graphBuilder)
m_graphBuilder = Nothing
End If
GC.Collect()
End Sub
' <summary> sample callback, Originally not used - call this with integer 0 on the setcallback method </summary>
Function SampleCB(ByVal SampleTime As Double, ByVal pSample As IMediaSample) As Integer Implements ISampleGrabberCB.SampleCB
myTest = "In SampleCB"
Dim i As Integer = 0
'jk added this code 10-22-13
If IsDBNull(pSample) = True Then Return -1
Dim myLen As Integer = pSample.GetActualDataLength()
Dim pbuf As IntPtr
If pSample.GetPointer(pbuf) = 0 And mylen > 0 Then
Dim buf As Byte() = New Byte(myLen) {}
Marshal.Copy(pbuf, buf, 0, myLen)
'Alter the video - you could use this to adjust the brightness/red/green, etc.
'for i = myLen-1 to 0 step -1
' buf(i) = (255 - buf(i))
'Next i
If m_takePicture Then
Dim bm As New Bitmap(m_videoWidth, m_videoHeight, Imaging.PixelFormat.Format24bppRgb)
Dim g_RowSizeBytes As Integer
Dim g_PixBytes() As Byte
mytest = "Execution point #1"
Dim m_BitmapData As BitmapData = Nothing
Dim bounds As Rectangle = New Rectangle(0, 0, m_videoWidth, m_videoHeight)
mytest = "Execution point #2"
m_BitmapData = bm.LockBits(bounds, Imaging.ImageLockMode.ReadWrite, Imaging.PixelFormat.Format24bppRgb)
mytest = "Execution point #4"
g_RowSizeBytes = m_BitmapData.Stride
mytest = "Execution point #5"
' Allocate room for the data.
Dim total_size As Integer = m_BitmapData.Stride * m_BitmapData.Height
ReDim g_PixBytes(total_size)
mytest = "Execution point #10"
'this writes the data to the Bitmap
Marshal.Copy(buf, 0, m_BitmapData.Scan0, mylen)
capturedPic = bm
mytest = "Execution point #15"
' Release resources.
bm.UnlockBits(m_BitmapData)
g_PixBytes = Nothing
m_BitmapData = Nothing
bm = Nothing
buf = Nothing
m_takePicture = False
captureSaved = True
mytest = "Execution point #20"
End If
End If
Marshal.ReleaseComObject(pSample)
Return 0
End Function
' <summary> buffer callback, Not used - call this with integer 1 on the setcallback method </summary>
Function BufferCB(ByVal SampleTime As Double, ByVal pBuffer As IntPtr, ByVal BufferLen As Integer) As Integer Implements ISampleGrabberCB.BufferCB
SyncLock Me
myTest = "In BufferCB"
End SyncLock
Return 0
End Function
End Class
Can someone help to achieve my goal described above.
1) Enumerating Devices in Combobox
2) Snapshot selected webcam device to a file.
Any help is appreciated :)
I'm using AForge (My program does a bit more, but this will give you a start)
Mine does not pop-up the dialog, because it enumerates it itself (You may want just that code chunk)
You can also set all the My.Settings to hard-coded settings.
This does create a display for the video, but you can simply set vspMonitor.visible = False if you don't want it to display.
Imports AForge.Controls
Imports AForge.Video
Imports AForge.Video.DirectShow
Imports AForge.Video.VFW
Imports System.IO
Public Class Main
Private WithEvents timer As New Timer
'Stores the file path, e.g.: "F:\Temp"
Friend Shared strICLocation As String = My.Settings.ICSet
'Stores the common name for the file, such as "Capture" (Screenshot, whatever you want)
Friend Shared strICFileRootName As String = My.Settings.ICRootName
'Stores the image format to save in a 3 char string: PNG, JPG, BMP
Friend Shared strICType As String = My.Settings.ICType
Dim VideoCaptureSource As VideoCaptureDevice
Dim VideoDevices As New FilterInfoCollection(FilterCategory.VideoInputDevice)
Private Property VideoCapabilities As VideoCapabilities()
Dim frame As System.Drawing.Bitmap
Dim filename As String
Private Sub Main_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
'You'll need the following items in your UI at minimum:
'Button named btnConnect, button named btnDisconnect, Video Source Player (From AForge libraries) named vspMonitor, a Combo Box named cmbVideoSource
EnumerateVideoDevices()
btnDisconnect.Enabled = False
btnConnect.Enabled = True
strICFileRootName = My.Settings.ICRootName
strICLocation = My.Settings.ICSet
lblICLocation.Text = strICLocation
End Sub
Private Sub EnumerateVideoDevices()
' enumerate video devices
VideoDevices = New FilterInfoCollection(FilterCategory.VideoInputDevice)
If VideoDevices.Count <> 0 Then
' add all devices to combo
For Each device As FilterInfo In VideoDevices
cmbVideoSource.Items.Add(device.Name)
cmbVideoSource.SelectedIndex = 0
VideoCaptureSource = New VideoCaptureDevice(VideoDevices(cmbVideoSource.SelectedIndex).MonikerString)
EnumerateVideoModes(VideoCaptureSource)
Next
Else
cmbVideoSource.Items.Add("No DirectShow devices found")
End If
cmbVideoSource.SelectedIndex = 0
End Sub
Private Sub EnumerateVideoModes(device As VideoCaptureDevice)
' get resolutions for selected video source
Me.Cursor = Cursors.WaitCursor
cmbVideoModes.Items.Clear()
Try
Dim VideoCapabilities = device.VideoCapabilities
For Each capabilty As VideoCapabilities In VideoCapabilities
If Not cmbVideoModes.Items.Contains(capabilty.FrameSize) Then
cmbVideoModes.Items.Add(capabilty.FrameSize)
End If
Next
If VideoCapabilities.Length = 0 Then
cmbVideoModes.Items.Add("Not supported")
End If
cmbVideoModes.SelectedIndex = 0
Finally
Me.Cursor = Cursors.[Default]
End Try
End Sub
#Region "IC (Image Capture)"
Private Sub btnICOptions_Click(sender As Object, e As EventArgs) Handles btnICOptions.Click
' I use a form to set to image save type; handle it however you want, including hard-coding it
Dim frm As New frmICOptions
frm.Show()
End Sub
Private Sub btnICSet_Click(sender As Object, e As EventArgs) Handles btnICSet.Click
'Make a button called btnICSet to set the save path
Dim dialog As New FolderBrowserDialog()
dialog.Description = "Select Image Capture save path"
If dialog.ShowDialog() = Windows.Forms.DialogResult.OK Then
strICLocation = dialog.SelectedPath
lblICLocation.Text = strICLocation
End If
End Sub
Private Sub ICCapture_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnICCapture.Click
'Need a button called btnICCapture. This is what will initiate the screen cap.
Try
If vspMonitor.IsRunning = True Then
If My.Settings.ICType = "PNG" Then
Dim strFilename As String = strICFileRootName & " " & Format(Now, "yyyy-MMM-dd HH.mm.ss.fff") & ".png"
vspMonitor.GetCurrentVideoFrame.Save(strICLocation & "\" & strFilename, System.Drawing.Imaging.ImageFormat.Png)
ElseIf My.Settings.ICType = "JPG" Then
Dim strFilename As String = strICFileRootName & " " & Format(Now, "yyyy-MMM-dd HH.mm.ss.fff") & ".jpg"
vspMonitor.GetCurrentVideoFrame.Save(strICLocation & "\" & strFilename, System.Drawing.Imaging.ImageFormat.Jpeg)
Else
Dim strFilename As String = strICFileRootName & " " & Format(Now, "yyyy-MMM-dd HH.mm.ss.fff") & ".bmp"
vspMonitor.GetCurrentVideoFrame.Save(strICLocation & "\" & strFilename, System.Drawing.Imaging.ImageFormat.Bmp)
End If
End If
Catch ex As Exception
MessageBox.Show("Try taking snapshot again when video image is visible.", "Cannot Save Image", MessageBoxButtons.OK, MessageBoxIcon.Error)
End Try
End Sub
#End Region
End Class
There may be some extraneous (to your purpose) variables and settings (my app does Image capture, screen capture, video capture, Stop Motion capture (to images or video) and Motion Detect Capture to video, so I basically yanked this code from it trying to get you in the right direction.) I'll be happy to modify it if I've left any errors.