VB.Net PrintForm autofit - vb.net

Im having trouble with autofitting the printed form in my application.
My code at the moment looks like this.
Dim pf As New PowerPacks.Printing.PrintForm
pf.Form = Me
pf.PrinterSettings.DefaultPageSettings.Landscape = True
pf.Print(Me, PowerPacks.Printing.PrintForm.PrintOption.ClientAreaOnly)
However, it cuts off a chunk of my form on the printed page.
I cant find anything to do with Autofit on the internet so hopefully one of you guys can come up with something.

Imports System.Drawing
Imports System.Windows.Forms
''' <summary>
''' Prints a screengrab of the form
''' </summary>
''' <remarks></remarks>
Public Class PrintForm
'USAGE:
' Dim pf As New PrintForm(Me)
' pf.PrintPreview()
' - or-
' pf.Print()
'
Private Declare Auto Function BitBlt Lib "gdi32.dll" (ByVal hDIDest 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 System.Int32) As Boolean ' API call to help generate final screenshot
Private mbmpScreenshot As Bitmap ' Variable to store screenshot
Private mblnLandscape As Boolean = False
Public Enum PrintMode_ENUM As Integer
[Default]
FitToPage
End Enum
Private menuPrintMode As PrintMode_ENUM = PrintMode_ENUM.Default
'
Private mfrm As Form
Public Sub New(ByVal frm As Form)
mfrm = frm
Call GrabScreen()
End Sub
'
''' <summary>
''' Determines page settings for current page e.g. Orientation
''' </summary>
''' <param name="sender"></param>
''' <param name="e"></param>
''' <remarks></remarks>
Private Sub QueryPageSettings(ByVal sender As System.Object, ByVal e As System.Drawing.Printing.QueryPageSettingsEventArgs)
'
Dim pgsTemp As System.Drawing.Printing.PageSettings = New System.Drawing.Printing.PageSettings()
pgsTemp.Landscape = mblnLandscape
e.PageSettings = pgsTemp
'
End Sub
'
Public Sub Print(landscape As Boolean, printMode As PrintMode_ENUM, Optional ByVal docname As String = "PrintForm", Optional ByVal PrinterName As String = "")
mblnLandscape = landscape
menuPrintMode = printMode
'create the document object
Using pdcNew As New Printing.PrintDocument
'
'wire up event handlers to handle pagination
AddHandler pdcNew.PrintPage, AddressOf PrintPage
AddHandler pdcNew.QueryPageSettings, AddressOf QueryPageSettings
'
Using docOutput As Printing.PrintDocument = pdcNew
If PrinterName > "" Then
docOutput.PrinterSettings.PrinterName = PrinterName
End If
docOutput.DocumentName = docname
docOutput.Print()
End Using
End Using
End Sub
'
''' <summary>
''' Preview the Report on screen
''' </summary>
''' <remarks></remarks>
Public Sub PrintPreview(landscape As Boolean, printMode As PrintMode_ENUM, Optional ByVal docname As String = "PrintForm", Optional ByVal Owner As Form = Nothing)
mblnLandscape = landscape
menuPrintMode = printMode
'
'create the document object
Using pdcNew As New Printing.PrintDocument
'
'wire up event handlers to handle pagination
AddHandler pdcNew.PrintPage, AddressOf PrintPage
AddHandler pdcNew.QueryPageSettings, AddressOf QueryPageSettings
'
Using ppvPreview As New PrintPreviewDialog
ppvPreview.Document = pdcNew
ppvPreview.FindForm.WindowState = FormWindowState.Maximized
If IsNothing(Owner) Then
ppvPreview.ShowDialog()
Else
ppvPreview.ShowDialog(Owner)
End If
End Using
End Using
End Sub
Sub PrintPage(ByVal sender As System.Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs)
Dim g As Graphics = e.Graphics 'shortcut
'g.DrawRectangle(Pens.Red, e.MarginBounds) 'DEBUG: use this line to check margins
'
' Method that handles the printing
Using objImageToPrint As Graphics = e.Graphics
Select Case menuPrintMode
Case PrintMode_ENUM.FitToPage
Dim rctTarget As Rectangle
If (mbmpScreenshot.Width / mbmpScreenshot.Height) < (e.MarginBounds.Width / e.MarginBounds.Height) Then
'fit height
rctTarget = New Rectangle(e.MarginBounds.X, e.MarginBounds.Y, CInt(mbmpScreenshot.Width * e.MarginBounds.Height / mbmpScreenshot.Height), e.MarginBounds.Height)
Else
'fit width
rctTarget = New Rectangle(e.MarginBounds.X, e.MarginBounds.Y, e.MarginBounds.Width, CInt(mbmpScreenshot.Height * e.MarginBounds.Width / mbmpScreenshot.Width))
End If
'g.DrawRectangle(Pens.Blue, rctTarget) 'DEBUG: use this line to check target rectangle
objImageToPrint.DrawImage(mbmpScreenshot, rctTarget)
Case Else 'default
objImageToPrint.DrawImage(mbmpScreenshot, 0, 0)
End Select
End Using
'
e.HasMorePages = False
End Sub
'
Private Sub GrabScreen()
' Performs a screenshot, saving results to bmpScreenshot
Dim objGraphics As Graphics = mfrm.CreateGraphics
Dim rctForm As Rectangle = mfrm.ClientRectangle 'including the border is beyond the scope of this demo program. See http://support.microsoft.com/kb/84066 for GetSystemMetrics() API to get size of border
'
Const SRCCOPY As Integer = &HCC0020
mbmpScreenshot = New Bitmap(rctForm.Width, rctForm.Height, objGraphics)
Dim objGraphics2 As Graphics = Graphics.FromImage(mbmpScreenshot)
Dim deviceContext1 As IntPtr = objGraphics.GetHdc
Dim deviceContext2 As IntPtr = objGraphics2.GetHdc
'
BitBlt(deviceContext2, rctForm.X, rctForm.Y, rctForm.Width, rctForm.Height, deviceContext1, 0, 0, SRCCOPY)
objGraphics.ReleaseHdc(deviceContext1)
objGraphics2.ReleaseHdc(deviceContext2)
End Sub
'
End Class
'

Personally, I don't much like the PowerPacks.Printing.PrintForm. I'd rather just use GDI+ and have more control over how it prints. This article might help:
http://www.c-sharpcorner.com/uploadfile/srajlaxmi/printing-windows-form-in-C-Sharp-net/

Related

CoreAudio in vb.net 6.0 Windows 11 : Is there a way to do a ControlChangeNotify callback?

I am writing a volume control app in vb.net 6.0, using a reference to CoreAudioApi.dll.
I can:
Change the volume of the default render and capture devices.
Mute the default devices.
Alter the balance on the render device
List the full names, guid string and status of all the devices
However, despite a lot of research, I can not setup a callback for ControlChangeNotify.
It appears to be simple in C, however I am writing in VB. Can any one suggest a solution?
Update 18/12/2022 #Jimi supplied some very useful definitions and I have edited the post to show the current code attempts. I can get the master default volume using masterVol = GetMasterVolumeObject() as an IAudioEndpointVolume.
Update 22/12/2022 Following a re-read of many postings it became apparent that it was important to create a persistent reference to mastervol and the class reference (MyCallBack) to the class module implementing IAudioEndpointVolumeCallback.
Update 24/12/2022 The AudioCallback class is now firing when volume/mute are changed internally and externally. Transferring the callback data to the main form is problematic. I now have a working system which involves:
Declaring public events in the call back class for each type of control I want to change in the main form.
Initiating a BackgroundWorker to Process the data 10mS after being called by the callback class.
Calculating new audio values from the pNotifyData pointer.
RaiseEvent for each slider/checkbox and label in the main form that needs updating.
AddHandler in the main form to process the callback events.
Create handler routines with delegates for each control type.
From my point of view this topic is solved.
My thanks to #Jimi for his contribution.
Latest Updates:
Option Explicit On
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Public Class AudioCallback
Implements IAudioEndpointVolumeCallback
Public Event LabelReady(sender As AudioCallback, ByVal T As String)
Public Event SliderReady(sender As AudioCallback, EP As String, ByVal T As Integer)
Public Event CheckReady(sender As AudioCallback, EP As String, ByVal T As Boolean)
Public Function OnNotify(pNotifyData As IntPtr) As Integer Implements IAudioEndpointVolumeCallback.OnNotify
' Move to global structure
Gstructure = Marshal.PtrToStructure(pNotifyData, GetType(AUDIO_VOLUME_NOTIFICATION_DATA))
BackGround() ' Asynchronous call and delagate controls
Return 0
End Function
Private Sub BackGround()
Dim bgw = New BackgroundWorker()
AddHandler bgw.DoWork,
Sub()
System.Threading.Thread.Sleep(10)
End Sub
AddHandler bgw.RunWorkerCompleted,
Sub()
Update()
End Sub
bgw.RunWorkerAsync()
End Sub
Private Sub Update()
Dim svolL As Integer
Dim svolR As Integer
Dim balance As Integer
'ChkMaster.Checked = Gstructure.bMuted
RaiseEvent CheckReady(Me, "R", Gstructure.bMuted)
svolL = 0.5 + 100 * Gstructure.Left
svolR = 0.5 + 100 * Gstructure.Right
If svolL = svolR Then
balance = 0
Else
If svolR > svolL Then
balance = 100 - svolL * 100.0 / svolR
Else
balance = -(100 - svolR * 100.0 / svolL)
End If
End If
RaiseEvent SliderReady(Me, "RV", 0.5 + 100 * Gstructure.fMasterVolume) ' HMaster.Value = 0.5 + 100 * Gstructure.fMasterVolume
RaiseEvent SliderReady(Me, "RB", balance) ' HBalance.Value = balance
'LGuid.Text = Gstructure.guidEventContext.ToString
RaiseEvent LabelReady(Me, Gstructure.guidEventContext.ToString)
End Sub
End Class
' Main form Extracts ============================================
Imports CoreAudioApi
Public Class Form1
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Me.Show()
' events for handling AudioCallback events
AddHandler MyCallBack.LabelReady, AddressOf LReady
AddHandler MyCallBack.SliderReady, AddressOf HReady
AddHandler MyCallBack.CheckReady, AddressOf CReady
End Sub
' Label Guid displays Callback GUID
' CheckBox ChkMaster displays Mute status
' Horizontal scrollbar HMaster displays default render volume
' Horizontal scrollbar HBalance displays default render balance
' The global variable IsSettingMaster prevents code associated
' with altering the value of the sliders from re-setting
' the volume / balance.
Private Sub LReady(sender As AudioCallback, Data As String) ' Set GUID label for Render
UpdateLabel(LGuid, Data)
End Sub
Private Delegate Sub UpdateLabelDelegate(TB As Label, param As String)
Private Sub UpdateLabel(TB As Label, param As String)
If TB.InvokeRequired Then
TB.Invoke(New UpdateLabelDelegate(AddressOf UpdateLabel), New Object() {TB, param})
Else
TB.Text = param
End If
End Sub
Private Sub CReady(sender As AudioCallback, EP As String, Data As Boolean) ' Set Master (Render) Mute checkbox
If EP = "R" Then UpdateChkbox(ChkMaster, Data)
End Sub
Private Delegate Sub UpdateChkboxDelegate(TB As CheckBox, param As Boolean)
Private Sub UpdateChkbox(TB As CheckBox, param As Boolean)
If TB.InvokeRequired Then
TB.Invoke(New UpdateChkboxDelegate(AddressOf UpdateChkbox), New Object() {TB, param})
Else
TB.Checked = param
End If
End Sub
Private Sub HReady(sender As AudioCallback, EP As String, Data As Integer) ' Set Master (Render) Volume / Master Balance slide
IsSettingMaster = True
If EP = "RV" Then UpdateHslide(HMaster, Data)
If EP = "RB" Then UpdateHslide(HBalance, Data)
IsSettingMaster = False
End Sub
Private Delegate Sub UpdateHslideDelegate(TB As HScrollBar, param As Integer)
Private Sub UpdateHslide(TB As HScrollBar, param As Integer)
If TB.InvokeRequired Then
TB.Invoke(New UpdateHslideDelegate(AddressOf UpdateHslide), New Object() {TB, param})
Else
TB.Value = param
End If
End Sub
History:
' ===============================
' Public Class containing Callback:
Option Explicit On
Imports System.Runtime.InteropServices
Public Class AudioCallback
Implements IAudioEndpointVolumeCallback
Public Function OnNotify(pNotifyData As IntPtr) As Integer Implements IAudioEndpointVolumeCallback.OnNotify
' Move to global structure
Gstructure = Marshal.PtrToStructure(pNotifyData, GetType(AUDIO_VOLUME_NOTIFICATION_DATA))
' Need mechanism to process new data in main form
' Must be asynchronous
' Raise event did not work
' Enabling Timer did not work
HaveChange = True ' Flag global variable
Return 0
End Function
End Class
' ===============================
' Public Class to Setup Callback:
Option Explicit On
Imports System.Runtime.InteropServices
' Implements IMMDevice, IMMDeviceEnumerator, IAudioEndpointVolume
' developed from https://exchangetuts.com/how-to-check-if-the-system-audio-is-muted-1641156904496320
Public Class CoreAudio
' Public definition in ModCoreaudioAlt https://stackoverflow.com/questions/52001368/how-to-check-if-the-system-audio-is-muted/52013031#52013031
' Public Interface IAudioEndpointVolumeCallback
' Public Structure AUDIO_VOLUME_NOTIFICATION_DATA
' Public Interface IMMDevice
' Public Interface IMMDeviceEnumerator
' End Public definition in ModCoreaudioAlt ==============================
Dim CLSID_MMDeviceEnumerator As Guid = New Guid("{BCDE0395-E52F-467C-8E3D-C4579291692E}")
Dim MMDeviceEnumeratorType As Type = Type.GetTypeFromCLSID(CLSID_MMDeviceEnumerator, True)
Private hr As Integer
Friend Enum EDataFlow
eRender
eCapture
eAll
EDataFlow_enum_count
End Enum
Friend Enum ERole
eConsole
eMultimedia
eCommunications
ERole_enum_count
End Enum
<Flags>
Friend Enum CLSCTX As UInteger
CLSCTX_INPROC_SERVER = &H1 ' In CLSCTX_ALL
CLSCTX_INPROC_HANDLER = &H2 ' In CLSCTX_ALL
CLSCTX_LOCAL_SERVER = &H4 ' In CLSCTX_ALL
CLSCTX_INPROC_SERVER16 = &H8
CLSCTX_REMOTE_SERVER = &H10 ' In CLSCTX_ALL
CLSCTX_INPROC_HANDLER16 = &H20
CLSCTX_RESERVED1 = &H40
CLSCTX_RESERVED2 = &H80
CLSCTX_RESERVED3 = &H100
CLSCTX_RESERVED4 = &H200
CLSCTX_NO_CODE_DOWNLOAD = &H400
CLSCTX_RESERVED5 = &H800
CLSCTX_NO_CUSTOM_MARSHAL = &H1000
CLSCTX_ENABLE_CODE_DOWNLOAD = &H2000
CLSCTX_NO_FAILURE_LOG = &H4000
CLSCTX_DISABLE_AAA = &H8000
CLSCTX_ENABLE_AAA = &H10000
CLSCTX_FROM_DEFAULT_CONTEXT = &H20000
CLSCTX_ACTIVATE_32_BIT_SERVER = &H40000
CLSCTX_ACTIVATE_64_BIT_SERVER = &H80000
CLSCTX_INPROC = CLSCTX_INPROC_SERVER Or CLSCTX_INPROC_HANDLER
CLSCTX_SERVER = CLSCTX_INPROC_SERVER Or CLSCTX_LOCAL_SERVER Or CLSCTX_REMOTE_SERVER ' In CLSCTX_ALL
CLSCTX_ALL = CLSCTX_SERVER Or CLSCTX_INPROC_HANDLER
End Enum
Friend Function GetMasterVolumeObject() As IAudioEndpointVolume
' Get the default IAudioEndpintVolume as "ppEndpoint" for eRender & eMultimedia
Dim deviceEnumerator As IMMDeviceEnumerator = Nothing
Dim MediaDevice As IMMDevice = Nothing
Dim ppEndpoint As IAudioEndpointVolume = Nothing
Dim EndPointVolID As Guid = GetType(IAudioEndpointVolume).GUID
Try
Dim MMDeviceEnumerator As Object = Activator.CreateInstance(MMDeviceEnumeratorType)
deviceEnumerator = CType(MMDeviceEnumerator, IMMDeviceEnumerator)
deviceEnumerator.GetDefaultAudioEndpoint(EDataFlow.eRender, ERole.eMultimedia, MediaDevice)
MediaDevice.Activate(EndPointVolID, CLSCTX.CLSCTX_ALL, IntPtr.Zero, ppEndpoint)
Catch ex As Exception
Form1.Showme("Error in GetMasterVolumeObject: " & ex.Message, Color.Red)
ppEndpoint = Nothing
Finally
If Not IsNothing(deviceEnumerator) Then Marshal.ReleaseComObject(deviceEnumerator)
If Not IsNothing(MediaDevice) Then Marshal.ReleaseComObject(MediaDevice)
End Try
Return ppEndpoint
End Function
Public Sub Callback()
Try
masterVol = GetMasterVolumeObject()
' MyCallBack defined in Module ModCoreAudioAlt : Public MyCallBack As New AudioCallback
If IsNothing(MyCallBack) Then
Form1.Showme("Failed to set MyCallBack", Color.Red)
Else
hr = masterVol.RegisterControlChangeNotify(MyCallBack)
If hr <> 0 Then
Form1.Showme("Callback register failed", Color.Red)
If Not IsNothing(masterVol) Then Marshal.ReleaseComObject(masterVol)
Else
Form1.Showme("Callback register OK", Color.Blue)
CallBackOn = True
End If
End If
Catch ex As Exception
Form1.Showme("CallBack error " & ex.Message, Color.Red)
If Not IsNothing(masterVol) Then Marshal.ReleaseComObject(masterVol)
End Try
End Sub
Public Sub Cancelcallback()
If CallBackOn = False Then Exit Sub
hr = masterVol.UnregisterControlChangeNotify(MyCallBack)
If hr <> 0 Then
MsgBox("Callback Failed to UnRegister", vbOK, "Core Audio Callback")
Else
If Not IsNothing(masterVol) Then Marshal.ReleaseComObject(masterVol)
Form1.Showme("Callback Un-register OK", Color.Blue)
CallBackOn = False
End If
End Sub
End Class
' ==============
' Public Module:
Imports System.Runtime.InteropServices
Imports CoreAudioApi
Module ModCoreAudioAlt
' https://stackoverflow.com/questions/74833398/coreaudio-in-vb-net-6-0-windows-11-Is-there-a-way-to-do-a-controlchangenotify
Public CallBackOn As Boolean = False ' Callback is on Flag
Public masterVol As IAudioEndpointVolume = Nothing
Public MyCallBack As New AudioCallback
Public Gstructure As New AUDIO_VOLUME_NOTIFICATION_DATA ' Callback data
Public HaveChange As Boolean = False ' Callback has fired
<ComImport>
<Guid("657804FA-D6AD-4496-8A60-352752AF4F89")>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IAudioEndpointVolumeCallback
<PreserveSig()>
Function OnNotify(pNotifyData As IntPtr) As Integer
End Interface
<StructLayout(LayoutKind.Sequential)>
Public Structure AUDIO_VOLUME_NOTIFICATION_DATA
Public guidEventContext As Guid
Public bMuted As Boolean
Public fMasterVolume As Single
Public nChannels As UInteger
Public Left As Single ' .net will not allow pre-dimensioned array (aVolumes(1) as single)
Public Right As Single
End Structure
' https://gist.github.com/sverrirs/d099b34b7f72bb4fb386
<ComImport>
<Guid("5CDF2C82-841E-4546-9722-0CF74078229A")>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IAudioEndpointVolume
Function RegisterControlChangeNotify(<MarshalAs(UnmanagedType.Interface)> pNotify As IAudioEndpointVolumeCallback) As Integer
Function UnregisterControlChangeNotify(<MarshalAs(UnmanagedType.Interface)> pNotify As IAudioEndpointVolumeCallback) As Integer
Function GetChannelCount(ByRef channelCount As Integer) As HRESULT
Function SetMasterVolumeLevel() As HRESULT
Function SetMasterVolumeLevelScalar(level As Single, eventContext As Guid) As HRESULT
Function GetMasterVolumeLevel(<Out> ByRef level As Single) As HRESULT
Function GetMasterVolumeLevelScalar(<Out> ByRef level As Single) As HRESULT
Function SetChannelVolumeLevel(channelNumber As Integer, level As Single, eventContext As Guid) As HRESULT
Function SetChannelVolumeLevelScalar(channelNumber As Integer, level As Single, eventContext As Guid) As HRESULT
Function GetChannelVolumeLevel(channelNumber As Integer, <Out> ByRef level As Single) As HRESULT
Function GetChannelVolumeLevelScalar(channelNumber As Integer, <Out> ByRef level As Single) As HRESULT
Function SetMute(<MarshalAs(UnmanagedType.Bool)> isMuted As Boolean, eventContext As Guid) As HRESULT
Function GetMute(<Out> ByRef isMuted As Boolean) As HRESULT
Function GetVolumeStepInfo(<Out> ByRef pnStep As Integer, ByRef pnStepCount As Integer) As HRESULT
Function VolumeStepUp(eventContext As Guid) As HRESULT
Function VolumeStepDown(eventContext As Guid) As HRESULT
Function QueryHardwareSupport(<Out> ByRef hardwareSupportMask As Integer) As HRESULT
Function GetVolumeRange(<Out> ByRef volumeMin As Single, <Out> ByRef volumeMax As Single, <Out> ByRef volumeStep As Single) As HRESULT
End Interface
<ComImport>
<Guid("A95664D2-9614-4F35-A746-DE8DB63617E6")>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IMMDeviceEnumerator
Function EnumAudioEndpoints(ByVal dataFlow As EDataFlow, ByVal dwStateMask As Integer, <Out> ByRef ppDevices As IMMDeviceCollection) As HRESULT
' for 0x80070490 : Element not found
<PreserveSig>
Function GetDefaultAudioEndpoint(ByVal dataFlow As EDataFlow, ByVal role As ERole, <Out> ByRef ppEndpoint As IMMDevice) As HRESULT
Function GetDevice(ByVal pwstrId As String, <Out> ByRef ppDevice As IMMDevice) As HRESULT
Function NotImpl1() As Integer
End Interface
<ComImport>
<Guid("D666063F-1587-4E43-81F1-B948E807363F")>
<InterfaceType(ComInterfaceType.InterfaceIsIUnknown)>
Public Interface IMMDevice
Function Activate(ByRef iid As Guid, ByVal dwClsCtx As CLSCTX, ByVal pActivationParams As IntPtr, <Out> ByRef ppInterface As IAudioEndpointVolume) As HRESULT
Function OpenPropertyStore(ByVal stgmAccess As Integer, <Out> ByRef ppProperties As IPropertyStore) As HRESULT
Function GetId(<Out> ByRef ppstrId As IntPtr) As HRESULT
Function GetState(<Out> ByRef pdwState As Integer) As HRESULT
End Interface
End Module
' ==========
' Main Form:
Public Class Form1
' Contains:
' HMaster horizonal scroll 0-105 for Volume
' HBalance horizontal scroll -100 to 105 for Balance
' ChkMaster CheckBox for Mute
' LGuid label for Callback GUID
' Uses timer1 with 1 second interval to poll for Callback flag
Private Sub Timer1_Tick(sender As Object, e As EventArgs) Handles Timer1.Tick
If HaveChange = False Then Exit Sub
HaveChange = False
ChkMaster.Checked = Gstructure.bMuted
Dim svolL As Integer = 100 * Gstructure.Left
Dim svolR As Integer = 100 * Gstructure.Right
Dim balance As Integer
If svolL = svolR Then
balance = 0
Else
If svolR > svolL Then
balance = 100 - svolL * 100.0 / svolR
Else
balance = -(100 - svolR * 100.0 / svolL)
End If
End If
HMaster.Value = 100 * Gstructure.fMasterVolume
HBalance.Value = balance
LGuid.Text = (Gstructure.guidEventContext.ToString)
End Sub
Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
If CallBackOn Then ClassCoreAudio.Cancelcallback()
End Sub
end class

Variable value lost within 2 classes

I have tried the autocomplete code from here :
Need a VB.net Combobox derived class for pattern matched or contains autocomplete functionality
I added some code and I really don't understand why the NbrName is lost.
I added :
Case Keys.Enter
Text = _suggLb.Text
[Select](0, Text.Length)
_suggLb.Visible = False
'Mika
Dim myObject As Form1 = New Form1()
myObject.SearchByName(Text)
'Mika
Return
and this :
Public Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
'Mika Dim testbox As New AutoCompleteComboBox.SuggestComboBox
Me.Controls.Add(testbox)
testbox.DataSource = New List(Of String) From {"Janean Mcgaha", "Tama Gaitan", "Jacque Tinnin", "Elvira Woolfolk", "Fransisca Owens", "Minnie Ardoin",
"Renay Bentler", "Joye Boyter", "Jaime Flannery", "Maryland Arai", "Walton Edelstein", "Nereida Storrs",
"Theron Zinn", "Katharyn Estrella", "Alline Dubin", "Edra Bhatti", "Willa Jeppson", "Chelsea Revel",
"Sonya Lowy", "Danelle Kapoor"}
NbrName = 20
End Sub
Public Sub SearchByName(text As String)
Dim StrTmp As String
StrTmp = text + NbrName.ToString
End Sub
and unfortunately, the variable NbrName remains to 0.
Here under the whole code.
Can someone explain me where is the problem ?
Imports System.Collections.Generic
Imports System.ComponentModel
Imports System.Drawing
Imports System.Linq
Imports System.Linq.Expressions
Imports System.Windows.Forms
Public Class Form1
Dim testbox As New AutoCompleteComboBox.SuggestComboBox
Public NbrName As Integer
Public Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
'Mika Dim testbox As New AutoCompleteComboBox.SuggestComboBox
Me.Controls.Add(testbox)
testbox.DataSource = New List(Of String) From {"Janean Mcgaha", "Tama Gaitan", "Jacque Tinnin", "Elvira Woolfolk", "Fransisca Owens", "Minnie Ardoin",
"Renay Bentler", "Joye Boyter", "Jaime Flannery", "Maryland Arai", "Walton Edelstein", "Nereida Storrs",
"Theron Zinn", "Katharyn Estrella", "Alline Dubin", "Edra Bhatti", "Willa Jeppson", "Chelsea Revel",
"Sonya Lowy", "Danelle Kapoor"}
NbrName = 20
End Sub
Public Sub SearchByName(text As String)
Dim StrTmp As String
StrTmp = text + NbrName.ToString
End Sub
End Class
Namespace AutoCompleteComboBox
Public Class SuggestComboBox
Inherits ComboBox
#Region "fields and properties"
Private ReadOnly _suggLb As New ListBox() With {.Visible = False, .TabStop = False}
Private ReadOnly _suggBindingList As New BindingList(Of String)()
Private _propertySelector As Expression(Of Func(Of ObjectCollection, IEnumerable(Of String)))
Private _propertySelectorCompiled As Func(Of ObjectCollection, IEnumerable(Of String))
Private _filterRule As Expression(Of Func(Of String, String, Boolean))
Private _filterRuleCompiled As Func(Of String, Boolean)
Private _suggestListOrderRule As Expression(Of Func(Of String, String))
Private _suggestListOrderRuleCompiled As Func(Of String, String)
Public Property SuggestBoxHeight() As Integer
Get
Return _suggLb.Height
End Get
Set(value As Integer)
If value > 0 Then
_suggLb.Height = value
End If
End Set
End Property
''' <summary>
''' If the item-type of the ComboBox is not string,
''' you can set here which property should be used
''' </summary>
Public Property PropertySelector() As Expression(Of Func(Of ObjectCollection, IEnumerable(Of String)))
Get
Return _propertySelector
End Get
Set(value As Expression(Of Func(Of ObjectCollection, IEnumerable(Of String))))
If value Is Nothing Then
Return
End If
_propertySelector = value
_propertySelectorCompiled = value.Compile()
End Set
End Property
'''<summary>
''' Lambda-Expression to determine the suggested items
''' (as Expression here because simple lamda (func) is not serializable)
''' <para>default: case-insensitive contains search</para>
''' <para>1st string: list item</para>
''' <para>2nd string: typed text</para>
'''</summary>
Public Property FilterRule() As Expression(Of Func(Of String, String, Boolean))
Get
Return _filterRule
End Get
Set(value As Expression(Of Func(Of String, String, Boolean)))
If value Is Nothing Then
Return
End If
_filterRule = value
_filterRuleCompiled = Function(item) value.Compile()(item, Text)
End Set
End Property
'''<summary>
''' Lambda-Expression to order the suggested items
''' (as Expression here because simple lamda (func) is not serializable)
''' <para>default: alphabetic ordering</para>
'''</summary>
Public Property SuggestListOrderRule() As Expression(Of Func(Of String, String))
Get
Return _suggestListOrderRule
End Get
Set(value As Expression(Of Func(Of String, String)))
If value Is Nothing Then
Return
End If
_suggestListOrderRule = value
_suggestListOrderRuleCompiled = value.Compile()
End Set
End Property
#End Region
''' <summary>
''' ctor
''' </summary>
Public Sub New()
' set the standard rules:
_filterRuleCompiled = Function(s) s.ToLower().Contains(Text.Trim().ToLower())
_suggestListOrderRuleCompiled = Function(s) s
_propertySelectorCompiled = Function(collection) collection.Cast(Of String)()
_suggLb.DataSource = _suggBindingList
AddHandler _suggLb.Click, AddressOf SuggLbOnClick
AddHandler ParentChanged, AddressOf OnParentChanged
End Sub
''' <summary>
''' the magic happens here ;-)
''' </summary>
''' <param name="e"></param>
Protected Overrides Sub OnTextChanged(e As EventArgs)
MyBase.OnTextChanged(e)
If Not Focused Then
Return
End If
_suggBindingList.Clear()
_suggBindingList.RaiseListChangedEvents = False
_propertySelectorCompiled(Items).Where(_filterRuleCompiled).OrderBy(_suggestListOrderRuleCompiled).ToList().ForEach(AddressOf _suggBindingList.Add)
_suggBindingList.RaiseListChangedEvents = True
_suggBindingList.ResetBindings()
_suggLb.Visible = _suggBindingList.Any()
If _suggBindingList.Count = 1 AndAlso _suggBindingList.[Single]().Length = Text.Trim().Length Then
Text = _suggBindingList.[Single]()
[Select](0, Text.Length)
_suggLb.Visible = False
End If
End Sub
#Region "size and position of suggest box"
''' <summary>
''' suggest-ListBox is added to parent control
''' (in ctor parent isn't already assigned)
''' </summary>
''' <param name="sender"></param>
''' <param name="e"></param>
Private Overloads Sub OnParentChanged(sender As Object, e As EventArgs)
Parent.Controls.Add(_suggLb)
Parent.Controls.SetChildIndex(_suggLb, 0)
_suggLb.Top = Top + Height - 3
_suggLb.Left = Left + 3
_suggLb.Width = Width - 20
_suggLb.Font = New Font("Segoe UI", 9)
End Sub
Protected Overrides Sub OnLocationChanged(e As EventArgs)
MyBase.OnLocationChanged(e)
_suggLb.Top = Top + Height - 3
_suggLb.Left = Left + 3
End Sub
Protected Overrides Sub OnSizeChanged(e As EventArgs)
MyBase.OnSizeChanged(e)
_suggLb.Width = Width - 20
End Sub
#End Region
#Region "visibility of suggest box"
Protected Overrides Sub OnLostFocus(e As EventArgs)
' _suggLb can only getting focused by clicking (because TabStop is off)
' --> click-eventhandler 'SuggLbOnClick' is called
If Not _suggLb.Focused Then
HideSuggBox()
End If
MyBase.OnLostFocus(e)
End Sub
Private Sub SuggLbOnClick(sender As Object, eventArgs As EventArgs)
Text = _suggLb.Text
Focus()
End Sub
Private Sub HideSuggBox()
_suggLb.Visible = False
End Sub
Protected Overrides Sub OnDropDown(e As EventArgs)
HideSuggBox()
MyBase.OnDropDown(e)
End Sub
#End Region
#Region "keystroke events"
''' <summary>
''' if the suggest-ListBox is visible some keystrokes
''' should behave in a custom way
''' </summary>
''' <param name="e"></param>
Protected Overrides Sub OnPreviewKeyDown(e As PreviewKeyDownEventArgs)
If Not _suggLb.Visible Then
MyBase.OnPreviewKeyDown(e)
Return
End If
Select Case e.KeyCode
Case Keys.Down
If _suggLb.SelectedIndex < _suggBindingList.Count - 1 Then
_suggLb.SelectedIndex += 1
End If
Return
Case Keys.Up
If _suggLb.SelectedIndex > 0 Then
_suggLb.SelectedIndex -= 1
End If
Return
Case Keys.Enter
Text = _suggLb.Text
[Select](0, Text.Length)
_suggLb.Visible = False
'Mika
Dim myObject As Form1 = New Form1()
myObject.SearchByName(Text)
'Mika
Return
Case Keys.Escape
HideSuggBox()
Return
End Select
MyBase.OnPreviewKeyDown(e)
End Sub
Private Shared ReadOnly KeysToHandle As List(Of Keys) = New List(Of Keys) From {Keys.Down, Keys.Up, Keys.Enter, Keys.Escape}
Protected Overrides Function ProcessCmdKey(ByRef msg As Message, keyData As Keys) As Boolean
' the keysstrokes of our interest should not be processed be base class:
If _suggLb.Visible AndAlso KeysToHandle.Contains(keyData) Then
Return True
End If
Return MyBase.ProcessCmdKey(msg, keyData)
End Function
#End Region
End Class
End Namespace

Print Text or HTML to PDF without changing default printer and using Microsoft Print To PDF and no user prompts

I have a need to PDF print the body of an email, text or html, without human intervention and without changing the default printer.
I have answered my own question using pieces from StackOverflow and Microsoft. The answer is not perfect but it does work for me. Part of this sharing is to get some feedback on a better way to do this and provide an answer (maybe not the best one) to someone else problem.
'Usage
'Dim printpdf As New PrintToPDF
'printpdf.HTMLToPDF(filecontents, PDFfilename)
'or
'printpdf.TextToPDF(filecontents, PDFfilename)
Imports System.Drawing 'if not used in a form
Imports System.Windows.Forms 'if not used in a form
Imports System.Drawing.Drawing2D
Imports System.Drawing.Printing
Public Class PrintToPDF
Public Property PDFPrinterName As String = "Microsoft Print to PDF"
Public Property TextPrintFont As Font = New Font("Arial", 10, FontStyle.Regular)
Public Property SaveImagesOfPages As Boolean = False
Public Property SaveImagesOfPagesPath As String = "c:\temp"
Public Property SaveImagePageName As String = "testemail"
''' <summary>
''' Get or Set the color of the margin. The padded space around the image of the captured HTML
''' </summary>
''' <returns></returns>
Public Property ImageBorderColor As Color = Color.White
Private _PDFMargin As Margins = New Margins(20, 20, 20, 20)
''' <summary>
''' Get or Set printer margin spacing
''' </summary>
''' <returns></returns>
Public Property PDFMargin As Margins
Get
Return _PDFMargin
End Get
Set(value As Margins)
_PDFMargin = value
End Set
End Property
Private _PixelMargin As Integer = 5
''' <summary>
''' Get or Set the margin (ALL) added to the document to provide clean print edges for converting HTML or RTF.
''' Must be a positive integer
''' </summary>
''' <returns></returns>
Public Property PixelMargin As Integer
Get
Return _PixelMargin
End Get
Set(value As Integer)
If value < 1 Then value = 1
_PixelMargin = value
_PaperHeight = PDFPaperSize.Height - (2 * PixelMargin) 'x2 for L/R and T/B
_PaperWidth = PDFPaperSize.Width - (2 * PixelMargin) 'x2 for L/R and T/B
End Set
End Property
Private _PDFPaperSize As PaperSize = New PaperSize("Letter", 850, 1100)
Public Property PDFPaperSize As PaperSize
Get
Return _PDFPaperSize
End Get
Set(value As PaperSize)
_PDFPaperSize = value
_PaperHeight = PDFPaperSize.Height - (2 * PixelMargin) 'x2 for L/R and T/B
_PaperWidth = PDFPaperSize.Width - (2 * PixelMargin) 'x2 for L/R and T/B
End Set
End Property
'A polling variable to determine when the print job has completed
Private _PrintingComplete As Boolean = False
Private _PrintPDF As PrintDocument
Private _webControl As WebBrowser
Private _WEBControl_BMP As Bitmap = Nothing
Private _BMP_YOffset As Integer = 0 ' The variable that moves the bmp page/image down to the next segment/page
Private _BMP_PageCount As Integer = 1
Private _BMP_RemainingHeight As Integer = 0
Private _rftControl As RichTextBox
Private _RTFControl_BMP As Bitmap = Nothing
Private _TXT_PageCount As Integer = 1
Private _TextToPrint As String = ""
'just less than the 1100 for a letter so that it doesnt cut off so harse at the edge of a page
Private _PaperHeight As Integer = 1100
Private _PaperWidth As Integer = 850
Public Sub New()
End Sub
''' <summary>
''' For development. Does not work for TextToPDF
''' </summary>
''' <param name="SavePages"></param>
''' <param name="SavePagesPath"></param>
''' <param name="SavePageName"></param>
Public Sub New(ByVal SavePages As Boolean, ByVal SavePagesPath As String, ByVal SavePageName As String)
_SaveImagesOfPages = SavePages
_SaveImagesOfPagesPath = SavePagesPath
_SaveImagePageName = SavePageName
End Sub
#Region "HTML"
''' <summary>
''' Prints an image of rendered HTML to PDF
''' </summary>
''' <param name="HTMLCode"></param>
''' <param name="SaveToPDFFile"></param>
''' <returns></returns>
Public Function HTMLToPDF(ByVal HTMLCode As String, ByVal SaveToPDFFile As String) As Boolean
Dim rtnBool As Boolean = False
'Dim printPDF As New PrintDocument
Try
_PrintingComplete = False
If (SaveImagesOfPagesPath <> "") AndAlso (Not SaveImagesOfPagesPath.EndsWith("\")) Then SaveImagesOfPagesPath += "\"
_webControl = New WebBrowser 'give me a new instance for this event
_PrintPDF = New PrintDocument
With _PrintPDF
.DocumentName = "docHTMLCode" 'give it something for a name, you can see this in the print spooler as the job runs
.PrintController = New Printing.StandardPrintController
.DefaultPageSettings.Landscape = False
.DefaultPageSettings.PaperSize = PDFPaperSize 'New PaperSize("Letter", 850, 1100) '.DefaultPageSettings.PrinterSettings.PaperSizes(PaperKind.Letter) 'New PaperSize("Legal", 850, 1400)
'_PaperHeight = .DefaultPageSettings.PaperSize.Height
'.DefaultPageSettings.PrinterResolution = .PrinterSettings.PrinterResolutions(1)
.DefaultPageSettings.Color = True
.DefaultPageSettings.Margins = PDFMargin 'not currently being followed, that's why the HTMLInjectMargin was created
.PrinterSettings.Copies = 1
.PrinterSettings.PrinterName = _PDFPrinterName '"Microsoft Print to PDF"
.PrinterSettings.PrintToFile = True
.PrinterSettings.PrintFileName = SaveToPDFFile
End With
Dim pageBottom As Integer = 1
With _webControl
.ClientSize = New Size(_PaperWidth, _PaperHeight) 'give it some place to start
.DocumentText = "0"
.Document.OpenNew(True)
.Document.Write(HTMLCode)
.Refresh() 'let the new html load
While .ReadyState <> WebBrowserReadyState.Complete
Application.DoEvents()
End While
'make the size the same as an even number of full sheets of paper
pageBottom = .Document.Body.ScrollRectangle.Height - (_PixelMargin * 2) 'this is the length of the page as it was given
'now make the page long enough to be a full sheet of paper
If (pageBottom <= _PaperHeight) Then
'1 page and short
pageBottom = _PaperHeight
Else
'multiple pages
pageBottom = (((pageBottom \ _PaperHeight) + 1) * _PaperHeight)
End If
'changes the viewable size of the control
.ClientSize = New Size(_PaperWidth, pageBottom) 'now the client size is the same as X full sheets of paper
.Refresh() 'redraw so we can get a proper image capture, just in case
End With
'with everything set, do the print
AddHandler _PrintPDF.PrintPage, AddressOf WebControlPrintPage
AddHandler _PrintPDF.EndPrint, AddressOf WebControlEndPrint
_BMP_PageCount = 1 'give it a start page
'set some bounds for the big picture
_WEBControl_BMP = New Bitmap(_webControl.Bounds.Width - SystemInformation.VerticalScrollBarWidth, _webControl.Bounds.Height) '_webControl.Document.Body.ScrollRectangle.Bottom)
_webControl.DrawToBitmap(_WEBControl_BMP, _webControl.Bounds) 'fill those bounds with an image
_BMP_RemainingHeight = _WEBControl_BMP.Height 'after this, this height will start being subtracted
'Debug.Print("_webControl.Bounds.Width : " & _webControl.Bounds.Width.ToString & " _webControl.Bounds.Height : " & _webControl.Bounds.Height.ToString)
If SaveImagesOfPages Then Image.FromHbitmap(_WEBControl_BMP.GetHbitmap).Save(SaveImagesOfPagesPath & "FullPage_" & _SaveImagePageName & ".png", Imaging.ImageFormat.Png)
_PrintPDF.Print() 'this creates the actual pdf file from the PrintPage/WebControlPrint event
rtnBool = True
Stall(1) 'buy some time. noticed that even at this point, after the print, the calling function is unable to access the pdf just created as it is "busy"
'clean up
_webControl.Dispose()
_PrintPDF.Dispose()
_WEBControl_BMP.Dispose()
Catch ex As Exception
Debug.Print(ex.ToString)
End Try
Return rtnBool
End Function
Private Sub WebControlEndPrint(ByVal sender As Object, ByVal e As PrintEventArgs) 'Handles _PrintPDF.EndPrint
_PrintingComplete = True
'Stall(1)
End Sub
Private Sub WebControlPrintPage(ByVal sender As Object, ByVal e As PrintPageEventArgs) 'Handles _PrintPDF.PrintPage
'Dim rtnBool As Boolean = False
Try
'e.Graphics.PageUnit = GraphicsUnit.Pixel 'make the print super small and unreadable
e.Graphics.InterpolationMode = InterpolationMode.HighQualityBicubic
e.Graphics.PixelOffsetMode = PixelOffsetMode.HighQuality
e.Graphics.CompositingQuality = Drawing2D.CompositingQuality.HighQuality
e.Graphics.SmoothingMode = Drawing2D.SmoothingMode.HighQuality
'Dim destRect As RectangleF
Dim endOfPage As Integer = 0
Dim HasMorePages As Boolean = False
endOfPage = (_PaperHeight * _BMP_PageCount)
'Debug.Print("0, " & _BMP_YOffset.ToString & ", " & _WEBControl_BMP.Width.ToString & ", " & (endOfPage - _BMP_YOffset).ToString)
If (_BMP_RemainingHeight > _PaperHeight) Then 'more pages to print
'multipage
HasMorePages = True
Else
HasMorePages = False
End If
Dim srcRect As RectangleF = New RectangleF(0, _BMP_YOffset, _WEBControl_BMP.Width, (endOfPage - _BMP_YOffset)) 'region that should represent the location on the pdf to place the image
Dim b As Bitmap = _WEBControl_BMP.Clone(srcRect, _WEBControl_BMP.PixelFormat) 'the segment to print
Dim img As Image = AppendBorder(Image.FromHbitmap(b.GetHbitmap), PixelMargin)
If SaveImagesOfPages Then img.Save(SaveImagesOfPagesPath & _SaveImagePageName & "_Page_" & _BMP_PageCount.ToString & ".png", Imaging.ImageFormat.Png)
e.Graphics.DrawImage(img, e.MarginBounds)
_BMP_YOffset += _PaperHeight 'hold this value for the next run
_BMP_PageCount += 1
_BMP_RemainingHeight -= _PaperHeight 'remove a page worth of information
e.HasMorePages = HasMorePages
Catch ex As Exception
Debug.Print(ex.ToString)
End Try
'on exit clears the print spooler queue
End Sub
''' <summary>
''' Extracts text from HTML code
''' </summary>
''' <param name="HTMLCode"></param>
''' <returns></returns>
Public Function HtmlToPlainText(ByVal HTMLCode As String) As String
Dim rtnText As String = ""
Try
Dim webControl As New WebBrowser
webControl.DocumentText = "0"
webControl.Document.OpenNew(True)
webControl.Document.Write(HTMLCode)
webControl.Refresh()
'ExecCommand is supposed to be being deprecated soon, will have to come up with something different soon
webControl.Document.ExecCommand("SelectAll", False, Nothing)
webControl.Document.ExecCommand("Copy", False, Nothing)
webControl.Dispose()
webControl = Nothing
rtnText = Clipboard.GetText
Catch ex As Exception
Debug.Print(ex.ToString)
End Try
Return rtnText
End Function
#End Region
#Region "TEXT"
''' <summary>
''' Prints the text to a PDF file
''' </summary>
''' <param name="TextToPrint"></param>
''' <param name="SaveToPDFFile"></param>
''' <returns></returns>
Public Function TextToPDF(ByVal TextToPrint As String, ByVal SaveToPDFFile As String) As Boolean
Dim rtnBool As Boolean = False
Try
_PrintingComplete = False
_TextToPrint = TextToPrint
_PrintPDF = New PrintDocument
With _PrintPDF
.DocumentName = "docText" 'name shown in the print spooler
.PrintController = New Printing.StandardPrintController
.DefaultPageSettings.Landscape = False
.DefaultPageSettings.PaperSize = PDFPaperSize
.DefaultPageSettings.Color = True
.DefaultPageSettings.Margins = PDFMargin
.PrinterSettings.Copies = 1
.PrinterSettings.PrinterName = _PDFPrinterName
.PrinterSettings.PrintToFile = True
.PrinterSettings.PrintFileName = SaveToPDFFile
End With
'with everything set, do the print
AddHandler _PrintPDF.PrintPage, AddressOf TextPrintPage
AddHandler _PrintPDF.EndPrint, AddressOf TextEndPrint
_TXT_PageCount = 1 'give it a start page
_PrintPDF.Print() 'this creates the actual pdf file from the PrintPage/WebControlPrint event
rtnBool = True
Stall(1) 'buy some time. noticed that even at this point, after the print, the calling function is unable to access the pdf just created as it is "busy"
'clean up
_PrintPDF.Dispose()
Catch ex As Exception
Debug.Print(ex.ToString)
End Try
Return rtnBool
End Function
Private Sub TextPrintPage(ByVal sender As Object, ByVal e As PrintPageEventArgs)
'_TextToPrint
Dim charactersOnPage As Integer = 0
Dim linesPerPage As Integer = 0
e.Graphics.MeasureString(_TextToPrint, TextPrintFont, e.MarginBounds.Size, StringFormat.GenericTypographic, charactersOnPage, linesPerPage)
e.Graphics.DrawString(_TextToPrint, TextPrintFont, Brushes.Black, e.MarginBounds, StringFormat.GenericTypographic)
_TextToPrint = _TextToPrint.Substring(charactersOnPage)
e.HasMorePages = (_TextToPrint.Length > 0)
End Sub
Private Sub TextEndPrint(ByVal sender As Object, ByVal e As PrintEventArgs)
_PrintingComplete = True
End Sub
''' <summary>
''' Opens a text file and prints its contents to PDF
''' </summary>
''' <param name="FullPathDocumentToPrint"></param>
''' <param name="SaveToPDFFile"></param>
''' <returns></returns>
Public Function TextDocumentToPDF(ByVal FullPathDocumentToPrint As String, ByVal SaveToPDFFile As String) As Boolean ', Optional ByVal msWaitTime As Integer = 10000
Dim rtnBoolean As Boolean = False
If (FullPathDocumentToPrint <> "") Then
Try
_TextToPrint = My.Computer.FileSystem.ReadAllText(FullPathDocumentToPrint)
rtnBoolean = TextToPDF(_TextToPrint, SaveToPDFFile)
Catch ex As Exception
rtnBoolean = False
Debug.Print(ex.ToString)
End Try
End If
Return rtnBoolean
End Function
#End Region
Private Function AppendBorder(ByVal original As Image, ByVal borderWidth As Integer) As Image
Dim borderColor As Color = ImageBorderColor 'Color.Red
Dim mypen As New Pen(borderColor, borderWidth * 2)
Dim newSize As Size = New Size(original.Width + borderWidth * 2, original.Height + borderWidth * 2)
Dim img As Bitmap = New Bitmap(newSize.Width, newSize.Height)
Dim g As Graphics = Graphics.FromImage(img)
'g.Clear(borderColor)
g.DrawImage(original, New Point(borderWidth, borderWidth))
g.DrawRectangle(mypen, 0, 0, newSize.Width, newSize.Height)
g.Dispose()
Return img
End Function
''' <summary>
''' Creates a loop for a given number of seconds
''' </summary>
''' <param name="seconds"></param>
''' <remarks></remarks>
Public Sub Stall(ByVal Seconds As Single)
'Debug.Print(Now.ToString)
Dim eDate As Date = Date.Now.AddSeconds(Seconds)
While Now < eDate
Application.DoEvents()
End While
'Debug.Print(Now.ToString)
End Sub
End Class

Click messagebox from code

Alright so, don't ask why, PLEASE, but i really need this.
So, i'll display a MessageBox to the user for 2 seconds then i need to close it automatically, without the user input.
Messagebox.Show("RandomStringHere")
System.Threading.Thread.Sleep("2000")
And here i got stuck. Is there any way possible i can do this? And please don't ask why, but it is indeed necessary.
I couldn't find any help on the internet with this problem i have so i guess you guys can help me.
Just create your own form. You can do this in the designer or using code as in the example below. Set a timer and close the form in two seconds:
Private _msgForm As Form
Private _tmr As Windows.Forms.Timer
Private Sub Button9_Click(sender As Object, e As EventArgs) Handles Button9.Click
_msgForm = New Form
With _msgForm
.Height = 200
.Width = 300
.StartPosition = FormStartPosition.CenterScreen
.Text = "Message"
End With
Dim btn As New Button
With btn
.Text = "OK"
.Top = _msgForm.Height - 75
.Left = _msgForm.Width - 100
.Anchor = AnchorStyles.Right Or AnchorStyles.Bottom
End With
_msgForm.Controls.Add(btn)
Dim lbl As New Label
With lbl
.Text = "This is the text of the message box"
.Left = 0
.Top = 0
.Width = _msgForm.ClientSize.Width
.Height = _msgForm.ClientSize.Height - 120
.Anchor = AnchorStyles.Bottom Or AnchorStyles.Left Or AnchorStyles.Right Or AnchorStyles.Top
End With
_msgForm.Controls.Add(lbl)
_tmr = New Windows.Forms.Timer
With _tmr
.Interval = 2000
.Enabled = True
End With
AddHandler _tmr.Tick, AddressOf TimerTick
AddHandler btn.Click, AddressOf ButtonClick
_msgForm.ShowDialog()
End Sub
Private Sub TimerTick(sender As Object, e As EventArgs)
_msgForm.Close()
End Sub
Private Sub ButtonClick(sender As Object, e As EventArgs)
CType(sender, Button).FindForm.Close()
End Sub
Example usage:
Using New CenteredMessageBox(Owner:=Me,
TextFont:=Me.Font,
TimeOut:=2500)
MessageBox.Show("Test Text",
"Test Title",
MessageBoxButtons.OK,
MessageBoxIcon.Information)
End Using
The Custom MessageBox:
' [ Centered MessageBox ]
' By Elektro
'
' The author of the original idea is Hans Passant:
' http://stackoverflow.com/questions/2576156/winforms-how-can-i-make-messagebox-appear-centered-on-mainform
'
' Examples :
'
'Using New CenteredMessageBox(Owner:=Me,
' TextFont:=New Font("Lucida Console", Font.SizeInPoints, FontStyle.Bold),
' TimeOut:=2500)
'
' MessageBox.Show("Test Text", "Test Title", MessageBoxButtons.OK, MessageBoxIcon.Information)
'
'End Using
#Region " Centered MessageBox Class"
#Region " Imports "
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports System.Text
Imports System.Windows.Forms
#End Region
Class CenteredMessageBox : Implements IDisposable
#Region " Variables, Objects, Properties "
Private mTries As Integer = 0
Private mOwner As Form
Private mFont As Font
Private mTimeOut As Integer
Private WithEvents TimeoutTimer As Timer
Private ReadOnly Property MessageBoxWindowHandle As IntPtr
Get
Return _MessageBoxWindowHandle
End Get
End Property
Dim _MessageBoxWindowHandle As IntPtr = IntPtr.Zero
#End Region
#Region " P/Invoke "
Friend Class NativeMethods
Friend Const WM_SETFONT As Integer = &H30
Friend Const WM_GETFONT As Integer = &H31
Friend Delegate Function EnumThreadWndProc(hWnd As IntPtr, lp As IntPtr) As Boolean
Friend Declare Function SetWindowPos Lib "user32" (ByVal hwnd As IntPtr, ByVal hWndInsertAfter As IntPtr, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As UInt32) As Boolean
<DllImport("user32.dll")>
Friend Shared Function EnumThreadWindows(tid As Integer, callback As NativeMethods.EnumThreadWndProc, lp As IntPtr) As Boolean
End Function
<DllImport("kernel32.dll")>
Friend Shared Function GetCurrentThreadId() As Integer
End Function
<DllImport("user32.dll", CharSet:=CharSet.Unicode)>
Friend Shared Function GetClassName(hWnd As IntPtr, buffer As StringBuilder, buflen As Integer) As Integer
End Function
<DllImport("user32.dll")>
Friend Shared Function GetDlgItem(hWnd As IntPtr, item As Integer) As IntPtr
End Function
<DllImport("user32.dll")>
Friend Shared Function SendMessage(hWnd As IntPtr, msg As Integer, wp As IntPtr, lp As IntPtr) As IntPtr
End Function
<DllImport("user32.dll")>
Friend Shared Function GetWindowRect(hWnd As IntPtr, ByRef rc As RECT) As Boolean
End Function
<DllImport("user32.dll")>
Friend Shared Function MoveWindow(hWnd As IntPtr, x As Integer, y As Integer, w As Integer, h As Integer, repaint As Boolean) As Boolean
End Function
''' <summary>
''' <para>The DestroyWindow function destroys the specified window. The function sends WM_DESTROY and WM_NCDESTROY messages to the window to deactivate it and remove the keyboard focus from it. The function also destroys the window's menu, flushes the thread message queue, destroys timers, removes clipboard ownership, and breaks the clipboard viewer chain (if the window is at the top of the viewer chain).</para>
''' <para>If the specified window is a parent or owner window, DestroyWindow automatically destroys the associated child or owned windows when it destroys the parent or owner window. The function first destroys child or owned windows, and then it destroys the parent or owner window.</para>
''' <para>DestroyWindow also destroys modeless dialog boxes created by the CreateDialog function.</para>
''' </summary>
''' <param name="hwnd">Handle to the window to be destroyed.</param>
''' <returns>If the function succeeds, the return value is nonzero. If the function fails, the return value is zero. To get extended error information, call GetLastError.</returns>
<DllImport("user32.dll", CharSet:=CharSet.Unicode, SetLastError:=True)>
Friend Shared Function DestroyWindow(hwnd As IntPtr) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
End Class
Structure RECT
Public Left As Integer
Public Top As Integer
Public Right As Integer
Public Bottom As Integer
End Structure
#End Region
#Region " Constructors "
''' <summary>
''' Initializes a new instance of the <see cref="CenteredMessageBox"/> class.
''' </summary>
''' <param name="Owner">Indicates the form that owns this messagebox.</param>
''' <param name="TextFont">Indicates the text-font used to display the text label.</param>
''' <param name="TimeOut">
''' Indicates the timeout, in ms, to auto-close this <see cref="CenteredMessageBox"/>
''' Default is '0' which means Infinite.
''' </param>
Public Sub New(ByVal Owner As Form,
Optional TextFont As Font = Nothing,
Optional TimeOut As Integer = 0I)
mOwner = Owner
mFont = TextFont
mTimeOut = TimeOut
Owner.BeginInvoke(New MethodInvoker(AddressOf findDialog))
End Sub
#End Region
#Region " Private MEthods "
Private Sub findDialog()
' Enumerate windows to find the message box
If mTries < 0 Then
Return
End If
Dim callback As New NativeMethods.EnumThreadWndProc(AddressOf checkWindow)
If NativeMethods.EnumThreadWindows(NativeMethods.GetCurrentThreadId(), callback, IntPtr.Zero) Then
If System.Threading.Interlocked.Increment(mTries) < 10 Then
mOwner.BeginInvoke(New MethodInvoker(AddressOf findDialog))
End If
End If
If mTimeOut > 0 Then
TimeoutTimer = New Timer With {.Interval = mTimeOut, .Enabled = True}
TimeoutTimer.Start()
End If
End Sub
Private Function checkWindow(hWnd As IntPtr, lp As IntPtr) As Boolean
' Checks if <hWnd> is a dialog
Dim sb As New StringBuilder(260)
NativeMethods.GetClassName(hWnd, sb, sb.Capacity)
If sb.ToString() <> "#32770" Then Return True
' Get the STATIC control that displays the text
Dim hText As IntPtr = NativeMethods.GetDlgItem(hWnd, &HFFFF)
Me._MessageBoxWindowHandle = hWnd
Dim frmRect As New Rectangle(mOwner.Location, mOwner.Size)
Dim dlgRect As RECT
NativeMethods.GetWindowRect(hWnd, dlgRect)
If hText <> IntPtr.Zero Then
If mFont Is Nothing Then
' Get the current font
mFont = Font.FromHfont(NativeMethods.SendMessage(hText, NativeMethods.WM_GETFONT, IntPtr.Zero, IntPtr.Zero))
ElseIf mFont IsNot Nothing Then
NativeMethods.SetWindowPos(hText, 0, 70, 35, frmRect.Width, mFont.Height, 0)
End If
NativeMethods.SendMessage(hText, NativeMethods.WM_SETFONT, mFont.ToHfont(), New IntPtr(1))
' Resize and positionate the messagebox window:
NativeMethods.MoveWindow(hWnd,
frmRect.Left + (frmRect.Width - dlgRect.Right + dlgRect.Left) \ 2,
frmRect.Top + (frmRect.Height - dlgRect.Bottom + dlgRect.Top) \ 2,
(dlgRect.Right - dlgRect.Left),
(dlgRect.Bottom - dlgRect.Top), True)
End If
' Done
Return False
End Function
#End Region
#Region " Event Handlers "
Private Sub TimeoutTimer_Tick(ByVal sender As Object, ByVal e As EventArgs) Handles TimeoutTimer.Tick
NativeMethods.DestroyWindow(Me._MessageBoxWindowHandle)
Me.Dispose()
End Sub
#End Region
#Region " IDisposable "
Public Sub Dispose() Implements IDisposable.Dispose
mTries = -1
mOwner = Nothing
If mFont IsNot Nothing Then mFont.Dispose()
End Sub
#End Region
End Class
#End Region

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.