prevent "print screen" button in vb.net - vb.net

I made a simple windows form application using vb.net, the first element of my project "Form1.vb"contains common code such :
Public Class Form1
Public Sub Form1_Load
.....
End Class
I needed to disable "Print Screen" button in my application and I found the following code using google :
Option Explicit On
Imports System.ComponentModel
Imports System.Windows.Forms
Imports System.Runtime.InteropServices
Public Class HotKeyClass
Inherits Control
<DllImport("user32.dll")> _
Private Shared Function RegisterHotKey(hWnd As IntPtr, id As Integer, fsModifiers As Integer, vk As Integer) As Boolean
End Function
<DllImport("user32.dll")> _
Private Shared Function UnregisterHotKey(hWnd As IntPtr, id As Integer) As Boolean
End Function
<DllImport("user32.dll", SetLastError:=True)> _
Private Shared Sub keybd_event(bVk As Byte, bScan As Byte, dwFlags As UInteger, dwExtraInfo As Integer)
End Sub
Public Event HotKeyPressed(Key As Keys, Modifer As HotKeyModifer)
Private Const KEYEVENTF_KEYUP = &H2
Private Const WM_HOTKEY = &H312
Private m_Modifer As Integer
Private m_Key As Integer
Private m_Id As Integer
'Конструктор
Sub New()
Me.BackColor = Color.Black
Me.Visible = False
End Sub
'Обработка сообщений
Protected Overrides Sub WndProc(ByRef m As Message)
If m.Msg = WM_HOTKEY Then
'Dim idHotKey As Integer = CInt(m.WParam) 'Получаем идентификатор комбинации
RaiseEvent HotKeyPressed(m_Key, m_Modifer)
End If
MyBase.WndProc(m)
End Sub
'Переопределяем, получаем уникальный ID
Public Overrides Function GetHashCode() As Integer
Return m_Modifer ^ m_Key ^ Me.Handle.ToInt32()
End Function
'Переопределяем, снять регистрацию клавиш
Protected Overrides Sub Dispose(disposing As Boolean)
UnregisterHotKey(Me.Handle, Me.GetType().GetHashCode())
MyBase.Dispose(disposing)
End Sub
'Регистрация клавиш
Public Function Register(Key As Keys, Modifer As HotKeyModifer) As Boolean
m_Id = Me.GetHashCode()
m_Modifer = Modifer
m_Key = Key
Return RegisterHotKey(Me.Handle, m_Id, m_Modifer, m_Key)
End Function
'Снять регистрацию клавиш
Public Function Unregiser() As Boolean
Return UnregisterHotKey(Me.Handle, m_Id)
End Function
'Для эмуляции нажатия Ctrl + V
Public Shared Sub EmulateControlV()
keybd_event(Keys.ControlKey, 0, 0, 0)
keybd_event(Keys.V, 0, 0, 0)
keybd_event(Keys.V, 0, KEYEVENTF_KEYUP, 0)
keybd_event(Keys.ControlKey, 0, KEYEVENTF_KEYUP, 0)
End Sub
End Class
<Flags> _
Public Enum HotKeyModifer As UInteger
NO_MODIFICATION = 0
ALT = 1
CONTROL = 2
SHIFT = 4
WIN = 8
End Enum
Now how to use this code to detect "print screen" button press in order to stop the action?

Simply use the following code to achieve your purpose
Private Sub Form1_KeyUp(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles Me.KeyUp
' Prevent/Disable Print Screen
If e.KeyData = Keys.PrintScreen Then
Clipboard.Clear()
End If
End Sub

I already said this here: https://stackoverflow.com/questions/34238442/how-to-disable-printscreen-functionality-on-32-bit-64-bit-machine/34238923#34238923 but maybe it needs repeating :-)
You can monitor key presses and when the user pushes print screen (key code 44) execute a Clipboard.Clear(). It's pretty pointless though as anything you do in your application doesn't prevent the user from taking a picture of the screen with a mobile phone or using the screen capture software that is built into Windows (snipping tool).

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

How can I scroll a ListView by one row instead of the default three using the mouse wheel?

I have a modified ListView. When I scroll using the mouse wheel, it scrolls three rows.
I want it to scroll one row at a time using the mouse wheel.
Public Class listviewEx
Inherits ListView
Private Declare Function ShowScrollBar Lib "user32" (ByVal hwnd As IntPtr, ByVal wBar As Integer,
ByVal bShow As Boolean) As Integer
' Constants
Private Const SB_HORZ As Integer = 0
Private Const WM_HSCROLL As Integer = &H114
Private Const WM_VSCROLL As Integer = &H115
Public Event Scroll As ScrollEventHandler
Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
MyBase.WndProc(m)
ShowScrollBar(MyBase.Handle, SB_HORZ, False)
If m.Msg = &H115 Then
' Trap WM_VSCROLL
End If
End Sub
Public Sub New()
MyBase.New()
Me.SetStyle(ControlStyles.Opaque, True)
Me.SetStyle(ControlStyles.OptimizedDoubleBuffer, True)
Me.SetStyle(ControlStyles.ResizeRedraw, True)
Me.SetStyle(ControlStyles.AllPaintingInWmPaint, True)
Me.SetStyle(ControlStyles.EnableNotifyMessage, True)
End Sub
End Class
You can add a behavior to your ListView, to make it scroll one row instead of the default three, using the Ctrl key (as this modifier is often used to change this kind of behaviors) in combination with the mouse wheel.
You can then have the standard three-rows scroll when Ctrl is not pressed and one-row scroll behavior when it's pressed.
Override WndProc (as you're already doing), to handle WM_MOUSEWHEEL and verify that the Ctrl key is pressed, checking whether the low-word of WParam is MK_CONTROL = &H08.
When it's pressed, determine whether the delta is positive or negative and increment the value returned by ListView.TopItem.Index to then set the TopItem based on the calculated offset (adding a minimum/maximum check to avoid overflows):
Imports System.Windows.Forms
Public Class ListViewEx
Inherits ListView
Private Const WM_MOUSEWHEEL As Integer = &H20A
Private Const MK_CONTROL As Integer = &H8
Public Sub New()
End Sub
Protected Overrides Sub WndProc(ByRef m As Message)
MyBase.WndProc(m)
Select Case m.Msg
Case WM_MOUSEWHEEL
If Items.Count > 0 AndAlso (m.WParam.ToInt64() And &HFF) = MK_CONTROL Then
Dim offset = If((m.WParam.ToInt64() >> 16) > 0, -1, 1) + TopItem.Index
offset = Math.Max(Math.Min(offset, Items.Count - 1), 0)
TopItem = Items(offset)
m.Result = IntPtr.Zero
End If
End Select
End Sub
End Class
Someone named Viorel did it:
Public Class listviewEx
Inherits ListView
Protected Overrides Sub WndProc(ByRef m As Message)
Const WM_MOUSEWHEEL = &H20A
Select Case m.Msg
Case WM_MOUSEWHEEL
If TopItem IsNot Nothing Then
Dim d As Int16 = (m.WParam.ToInt32 >> 16)
Dim i As Integer
If d > 0 Then
i = Math.Max(TopItem.Index - 1, 0)
Else
i = Math.Min(TopItem.Index + 1, Items.Count - 1)
End If
TopItem = Items(i)
End If
m.Result = IntPtr.Zero
Return
End Select
MyBase.WndProc(m)
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 gamepad support, partially working

I found the following class code on a forum. It works great for the gamepad (up, down, left, right) however all the code for the buttons is missing. Can anyone fill in the blanks?
This works:
Private Sub joystick1_Up() Handles joystick1.Up
moveUp()
End Sub
This does not:
Private Sub joystick1_buttonPressed() Handles joystick1.buttonPressed
MsgBox(joystick1.btnValue)
End Sub
because there is no "buttonPressed" event and I have no idea how to write it.
And here's the class:
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Public Class joystick
Inherits NativeWindow
Private parent As Form
Private Const MM_JOY1MOVE As Integer = &H3A0
' Public Event Move(ByVal joystickPosition As Point)
Public btnValue As String
Public Event Up()
Public Event Down()
Public Event Left()
Public Event Right()
<StructLayout(LayoutKind.Explicit)> _
Private Structure JoyPosition
<FieldOffset(0)> _
Public Raw As IntPtr
<FieldOffset(0)> _
Public XPos As UShort
<FieldOffset(2)> _
Public YPos As UShort
End Structure
Private Class NativeMethods
Private Sub New()
End Sub
' This is a "Stub" function - it has no code in its body.
' There is a similarly named function inside a dll that comes with windows called
' winmm.dll.
' The .Net framework will route calls to this function, through to the dll file.
<DllImport("winmm", CallingConvention:=CallingConvention.Winapi, EntryPoint:="joySetCapture", SetLastError:=True)> _
Public Shared Function JoySetCapture(ByVal hwnd As IntPtr, ByVal uJoyID As Integer, ByVal uPeriod As Integer, <MarshalAs(UnmanagedType.Bool)> ByVal changed As Boolean) As Integer
End Function
End Class
Public Sub New(ByVal parent As Form, ByVal joyId As Integer)
AddHandler parent.HandleCreated, AddressOf Me.OnHandleCreated
AddHandler parent.HandleDestroyed, AddressOf Me.OnHandleDestroyed
AssignHandle(parent.Handle)
Me.parent = parent
Dim result As Integer = NativeMethods.JoySetCapture(Me.Handle, joyId, 100, True)
End Sub
Private Sub OnHandleCreated(ByVal sender As Object, ByVal e As EventArgs)
AssignHandle(DirectCast(sender, Form).Handle)
End Sub
Private Sub OnHandleDestroyed(ByVal sender As Object, ByVal e As EventArgs)
ReleaseHandle()
End Sub
Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
If m.Msg = MM_JOY1MOVE Then
' Joystick co-ords.
' (0,0) (32768,0) (65535, 0)
'
'
'
' (0, 32768) (32768, 32768) (65535, 32768)
'
'
'
'
' (0, 65535) (32768, 65535) (65535, 65535)
'
Dim p As JoyPosition
p.Raw = m.LParam
' RaiseEvent Move(New Point(p.XPos, p.YPos))
If p.XPos > 16384 AndAlso p.XPos < 49152 Then
' X is near the centre line.
If p.YPos < 6000 Then
' Y is near the top.
RaiseEvent Up()
ElseIf p.YPos > 59536 Then
' Y is near the bottom.
RaiseEvent Down()
End If
Else
If p.YPos > 16384 AndAlso p.YPos < 49152 Then
' Y is near the centre line
If p.XPos < 6000 Then
' X is near the left.
RaiseEvent Left()
ElseIf p.XPos > 59536 Then
' X is near the right
RaiseEvent Right()
End If
End If
End If
End If
If btnValue <> m.WParam.ToString Then
btnValue = m.WParam.ToString
End If
MyBase.WndProc(m)
End Sub
End Class
Instead of using the older winmm, I would use XInput instead (or if you can, use XNA).
There are a couple of ways you could go to do this. One step up is to use the XInput dlls directly as outlined by this question on the MSDN forums. That's still fairly ugly though. Probably the "easier" way to do this is using a wrapper library that exists out there like SlimDX or SharpDX.
One of the advantages of using XInput via SlimDX or SharpDX is that it will also work within a Windows Store app for Windows 8 :).
Here's a snippet from the GamePad sample in SharpDX:
C#
var controllers = new[] { new Controller(UserIndex.One), new Controller(UserIndex.Two), new Controller(UserIndex.Three), new Controller(UserIndex.Four) };
// Get 1st controller available
Controller controller = null;
foreach (var selectControler in controllers)
{
if (selectControler.IsConnected)
{
controller = selectControler;
break;
}
}
VB
Dim controllers As New List(Of Controller)
controllers.Add(New Controller(UserIndex.One))
controllers.Add(New Controller(UserIndex.Two))
controllers.Add(New Controller(UserIndex.Three))
controllers.Add(New Controller(UserIndex.Four))
Dim controller as Controller = Nothing;
For Each selectController In controllers
If selectController.IsConnected Then
controller = selectController
Exit For
End If
Next
Then you can get the state to work with using:
var state = controller.GetState();
You will notice that XInput uses more of a polling model, so you will need to occasionally check for a button press to detect this. If you need to poll continuously, you can probably spin up a new Task to do this on.

Vb.net app to track webbrowser popup

I have a webbrowser control on my form, when I navigate to a certain page it opens a popup which opens the page in the current default browser for windows, in this case IE. I would like to access the source code for this page. I dont want to close it, I just want to grab the html.
Thanks for your help.
Edit:
Slution:
eWebbrowser.vb :
Imports System
Imports System.Text
Imports System.Windows.Forms
Imports System.ComponentModel
Imports System.Collections.Generic
Imports System.Runtime.InteropServices
Imports System.Security.Permissions
<PermissionSet(SecurityAction.Demand, Name:="FullTrust")> _
<System.Runtime.InteropServices.ComVisibleAttribute(True)> _
Public Class eWebbrowser
Inherits System.Windows.Forms.WebBrowser
#Region " COM Imports Etc..."
<StructLayout(LayoutKind.Sequential)> _
Public Structure OLECMDTEXT
Public cmdtextf As UInt32
Public cwActual As UInt32
Public cwBuf As UInt32
Public rgwz As Char
End Structure
<StructLayout(LayoutKind.Sequential)> _
Public Structure OLECMD
Public cmdID As Long
Public cmdf As UInt64
End Structure
' Interop - IOleCommandTarget (See MSDN - http://support.microsoft.com/?kbid=311288)
<ComImport(), Guid("b722bccb-4e68-101b-a2bc-00aa00404770"), _
InterfaceType(ComInterfaceType.InterfaceIsIUnknown)> _
Public Interface IOleCommandTarget
Sub QueryStatus(ByRef pguidCmdGroup As Guid, ByVal cCmds As UInt32, _
<MarshalAs(UnmanagedType.LPArray, SizeParamIndex:=1)> ByVal prgCmds As OLECMD, _
ByRef pCmdText As OLECMDTEXT)
Sub Exec(ByRef pguidCmdGroup As Guid, ByVal nCmdId As Long, _
ByVal nCmdExecOpt As Long, ByRef pvaIn As Object, _
ByRef pvaOut As Object)
End Interface
Private cmdGUID As New Guid(&HED016940, -17061, _
&H11CF, &HBA, &H4E, &H0, &HC0, &H4F, &HD7, &H8, &H16)
#Region " Commands Enumeration "
'There are a ton of ole commands, we are only using a couple, msdn research will
'allow you to figure out which ones you want to use.
Enum oCommands As Long
Options
Find = 1
ViewSource = 2
'////////////////////////////////////////
ID_FILE_SAVEAS = 32771
ID_FILE_PAGESETUP = 32772
ID_FILE_IMPORTEXPORT = 32774
ID_FILE_PRINTPREVIEW = 32776
ID_FILE_NEWIE = 32779
ID_FILE_NEWMAIL = 32780
PID_FILE_NEWINTERNETCALL = 32781
ID_FILE_ADDTRUST = 32782
ID_FILE_ADDLOCAL = 32783
DLCTL_BGSOUNDS = &H40
DLCTL_DLIMAGES = &H10
DLCTL_DOWNLOADONLY = &H800
DLCTL_FORCEOFFLINE = &H10000000
DLCTL_NO_BEHAVIORS = &H800
DLCTL_NO_CLIENTPULL = &H20000000
DLCTL_NO_DLACTIVEXCTLS = &H400
DLCTL_NO_FRAMEDOWNLOAD = &H1000
DLCTL_NO_JAVA = &H100
DLCTL_NO_METACHARSET = &H10000
DLCTL_NO_RUNACTIVEXCTLS = &H200
DLCTL_NO_SCRIPTS = &H80
'DLCTL_OFFLINE DLCTL_OFFLINEIFNOTCONNECTED
DLCTL_OFFLINEIFNOTCONNECTED = &H80000000
DLCTL_PRAGMA_NO_CACHE = &H4000
DLCTL_RESYNCHRONIZE = &H2000
DLCTL_SILENT = &H40000000
DLCTL_URL_ENCODING_DISABLE_UTF8 = &H20000
DLCTL_URL_ENCODING_ENABLE_UTF8 = &H40000
DLCTL_VIDEOS = &H20
End Enum
#End Region
#End Region
'Just a little easier way to get at it.
Public ReadOnly Property CurrentURL() As String
Get
Return Me.Document.Url.ToString
End Get
End Property
Public Sub New()
MyBase.New()
End Sub
#Region " Dialogs "
Public Sub ShowOpen()
Dim cdlOpen As New OpenFileDialog
Try
cdlOpen.Filter = "HTML Files (*.htm)|*.htm|HTML Files (*.html)|*.html|TextFiles" & _
"(*.txt)|*.txt|Gif Files (*.gif)|*.gif|JPEG Files (*.jpg)|*.jpeg|" & _
"PNG Files (*.png)|*.png|Art Files (*.art)|*.art|AU Fles (*.au)|*.au|" & _
"AIFF Files (*.aif|*.aiff|XBM Files (*.xbm)|*.xbm|All Files (*.*)|*.*"
cdlOpen.Title = " Open File "
cdlOpen.ShowDialog()
If cdlOpen.FileName > Nothing Then
Me.Navigate(cdlOpen.FileName)
End If
Catch ex As Exception
Throw New Exception(ex.Message.ToString)
End Try
End Sub
Public Sub ShowSource()
Dim cmdt As IOleCommandTarget
Dim o As Object = Nothing
Dim oIE As Object = Nothing
Try
cmdt = CType(Me.Document.DomDocument, IOleCommandTarget)
cmdt.Exec(cmdGUID, oCommands.ViewSource, 1, o, o)
Catch ex As Exception
Throw New Exception(ex.Message.ToString, ex.InnerException)
Finally
cmdt = Nothing
End Try
End Sub
Public Sub ShowFindDialog()
Dim cmdt As IOleCommandTarget
Dim o As Object = Nothing
Dim oIE As Object = Nothing
Try
cmdt = CType(Me.Document.DomDocument, IOleCommandTarget)
cmdt.Exec(cmdGUID, oCommands.Find, 0, o, o)
Catch ex As Exception
Throw New Exception(ex.Message.ToString, ex.InnerException)
Finally
cmdt = Nothing
End Try
End Sub
Public Sub AddToFavorites(Optional ByVal strURL As String = "", Optional ByVal strTitle As String = "")
Dim oHelper As Object = Nothing
Try
oHelper = New ShellUIHelper
oHelper.AddFavorite(Me.Document.Url.ToString, Me.DocumentTitle.ToString)
Catch ex As Exception
Throw New Exception(ex.Message.ToString)
End Try
If oHelper IsNot Nothing AndAlso Marshal.IsComObject(oHelper) Then
Marshal.ReleaseComObject(oHelper)
End If
End Sub
Public Sub ShowOrganizeFavorites()
'Organize Favorites
Dim helper As Object = Nothing
Try
helper = New ShellUIHelper()
helper.ShowBrowserUI("OrganizeFavorites", 0)
Finally
If helper IsNot Nothing AndAlso Marshal.IsComObject(helper) Then
Marshal.ReleaseComObject(helper)
End If
End Try
End Sub
Public Sub SendToDesktop()
'Shortcut to desktop
Dim helper As Object = Nothing
Try
helper = New ShellUIHelper()
helper.AddDesktopComponent(Me.Document.Url.ToString, "website")
Finally
If helper IsNot Nothing AndAlso Marshal.IsComObject(helper) Then
Marshal.ReleaseComObject(helper)
End If
End Try
End Sub
''' <summary>
''' This Will launch the internet option dialog.
''' </summary>
''' <remarks></remarks>
Public Sub ShowInternetOptions()
Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", vbNormalFocus)
End Sub
Public Sub ShowPrivacyReport()
Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,2", vbNormalFocus)
End Sub
#End Region
#Region " Extended "
<ComImport(), _
Guid("34A715A0-6587-11D0-924A-0020AFC7AC4D"), _
InterfaceTypeAttribute(ComInterfaceType.InterfaceIsIDispatch), _
TypeLibType(TypeLibTypeFlags.FHidden)> _
Public Interface DWebBrowserEvents2
<DispId(250)> _
Sub BeforeNavigate2(<[In](), MarshalAs(UnmanagedType.IDispatch)> ByVal pDisp As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef URL As String, _
<InAttribute()> ByRef flags As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef targetFrameName As String, _
<InAttribute()> ByRef postdata As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef headers As String, _
<InAttribute(), OutAttribute()> ByRef cancel As Boolean)
'Note: Postdata is a SafeArray but for some reason, if I do a proper declaration, the event will not be raised:
'<[In](), MarshalAs(UnmanagedType.SafeArray, safearraysubtype:=VarEnum.VT_UI1)> ByRef postdata() As Byte, _
<DispId(273)> _
Sub NewWindow3(<InAttribute(), MarshalAs(UnmanagedType.IDispatch)> ByVal pDisp As Object, _
<InAttribute(), OutAttribute()> ByRef cancel As Boolean, _
<InAttribute()> ByRef Flags As Object, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef UrlContext As String, _
<InAttribute(), MarshalAs(UnmanagedType.BStr)> ByRef Url As String)
End Interface
Public Enum NWMF
NWMF_UNLOADING = &H1&
NWMF_USERINITED = &H2&
NWMF_FIRST_USERINITED = &H4&
NWMF_OVERRIDEKEY = &H8&
NWMF_SHOWHELP = &H10&
NWMF_HTMLDIALOG = &H20&
NWMF_FROMPROXY = &H40&
End Enum
Private cookie As AxHost.ConnectionPointCookie
Private wevents As WebBrowserExtendedEvents
'This method will be called to give you a chance to create your own event sink
Protected Overrides Sub CreateSink()
'MAKE SURE TO CALL THE BASE or the normal events won't fire
MyBase.CreateSink()
wevents = New WebBrowserExtendedEvents(Me)
cookie = New AxHost.ConnectionPointCookie(Me.ActiveXInstance, wevents, GetType(DWebBrowserEvents2))
End Sub
Protected Overrides Sub DetachSink()
If Not cookie Is Nothing Then
cookie.Disconnect()
cookie = Nothing
End If
MyBase.DetachSink()
End Sub
'This new event will fire when the page is navigating
Public Delegate Sub WebBrowserNavigatingExtendedEventHandler(ByVal sender As Object, ByVal e As WebBrowserNavigatingExtendedEventArgs)
Public Event NavigatingExtended As WebBrowserNavigatingExtendedEventHandler
'This event will fire when a new window is about to be opened
Public Delegate Sub WebBrowserNewWindowExtendedEventHandler(ByVal sender As Object, ByVal e As WebBrowserNewWindowExtendedEventArgs)
Public Event NewWindowExtended As WebBrowserNewWindowExtendedEventHandler
Protected Friend Sub OnNavigatingExtended(ByVal Url As String, ByVal Frame As String, ByVal Postdata As Byte(), ByVal Headers As String, ByRef Cancel As Boolean)
Dim e As WebBrowserNavigatingExtendedEventArgs = New WebBrowserNavigatingExtendedEventArgs(Url, Frame, Postdata, Headers)
RaiseEvent NavigatingExtended(Me, e)
Cancel = e.Cancel
End Sub
Protected Friend Sub OnNewWindowExtended(ByVal Url As String, ByRef Cancel As Boolean, ByVal Flags As NWMF, ByVal UrlContext As String)
Dim e As WebBrowserNewWindowExtendedEventArgs = New WebBrowserNewWindowExtendedEventArgs(Url, UrlContext, Flags)
RaiseEvent NewWindowExtended(Me, e)
Cancel = e.Cancel
End Sub
Public Overloads Sub Navigate2(ByVal URL As String)
MyBase.Navigate(URL)
End Sub
#End Region
#Region " Extended Event Classes "
'This class will capture events from the WebBrowser
Friend Class WebBrowserExtendedEvents
Inherits System.Runtime.InteropServices.StandardOleMarshalObject
Implements DWebBrowserEvents2
Private m_Browser As eWebbrowser
Public Sub New(ByVal browser As eWebbrowser)
m_Browser = browser
End Sub
'Implement whichever events you wish
Public Sub BeforeNavigate2(ByVal pDisp As Object, ByRef URL As String, ByRef flags As Object, ByRef targetFrameName As String, ByRef postData As Object, ByRef headers As String, ByRef cancel As Boolean) Implements DWebBrowserEvents2.BeforeNavigate2
m_Browser.OnNavigatingExtended(URL, targetFrameName, CType(postData, Byte()), headers, cancel)
End Sub
Public Sub NewWindow3(ByVal pDisp As Object, ByRef Cancel As Boolean, ByRef Flags As Object, ByRef UrlContext As String, ByRef Url As String) Implements DWebBrowserEvents2.NewWindow3
m_Browser.OnNewWindowExtended(Url, Cancel, CType(Flags, NWMF), UrlContext)
End Sub
End Class
Public Class WebBrowserNewWindowExtendedEventArgs
Inherits CancelEventArgs
Private m_Url As String
Private m_UrlContext As String
Private m_Flags As NWMF
Public ReadOnly Property Url() As String
Get
Return m_Url
End Get
End Property
Public ReadOnly Property UrlContext() As String
Get
Return m_UrlContext
End Get
End Property
Public ReadOnly Property Flags() As NWMF
Get
Return m_Flags
End Get
End Property
Public Sub New(ByVal url As String, ByVal urlcontext As String, ByVal flags As NWMF)
m_Url = url
m_UrlContext = urlcontext
m_Flags = flags
End Sub
End Class
'First define a new EventArgs class to contain the newly exposed data
Public Class WebBrowserNavigatingExtendedEventArgs
Inherits CancelEventArgs
Private m_Url As String
Private m_Frame As String
Private m_Postdata() As Byte
Private m_Headers As String
Public ReadOnly Property Url() As String
Get
Return m_Url
End Get
End Property
Public ReadOnly Property Frame() As String
Get
Return m_Frame
End Get
End Property
Public ReadOnly Property Headers() As String
Get
Return m_Headers
End Get
End Property
Public ReadOnly Property Postdata() As String
Get
Return PostdataToString(m_Postdata)
End Get
End Property
Public ReadOnly Property PostdataByte() As Byte()
Get
Return m_Postdata
End Get
End Property
Public Sub New(ByVal url As String, ByVal frame As String, ByVal postdata As Byte(), ByVal headers As String)
m_Url = url
m_Frame = frame
m_Postdata = postdata
m_Headers = headers
End Sub
Private Function PostdataToString(ByVal p() As Byte) As String
'not sexy but it works...
Dim tabpd() As Byte, bstop As Boolean = False, stmp As String = "", i As Integer = 0
tabpd = p
If tabpd Is Nothing OrElse tabpd.Length = 0 Then
Return ""
Else
For i = 0 To tabpd.Length - 1
stmp += ChrW(tabpd(i))
Next
stmp = Replace(stmp, ChrW(13), "")
stmp = Replace(stmp, ChrW(10), "")
stmp = Replace(stmp, ChrW(0), "")
End If
If stmp = Nothing Then
Return ""
Else
Return stmp
End If
End Function
End Class
#End Region
<ComImport(), Guid("64AB4BB7-111E-11D1-8F79-00C04FC2FBE1")> _
Public Class ShellUIHelper
'
End Class
End Class
form load:
Public WithEvents wb As eWebbrowser
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim brws As New eWebbrowser
wb = brws
End Sub
Events:
Private Sub wb_NewWindow(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles wb.NewWindow
e.Cancel = True
End Sub
The New Event:
Private Sub wb_NewWindowExtended(ByVal sender As Object, ByVal e As eWebbrowser.WebBrowserNewWindowExtendedEventArgs) Handles wb.NewWindowExtended
e.Cancel = True
Dim url As String = e.Url
msgbox(url) //This Is The Url!!
End Sub