VB.net Click through form - vb.net

I'm trying to make a program for my late night star gazing, I need my laptop screen to be only red, so I want to make a program that acts as a red filter. It would cover the whole screen and be transparent + red. The user can click through it, it would be just like putting a piece of transparent red plastic in-front of the screen.
So far I have a form that sizes itself to what ever your screen size is, and moves itself to the upper left corner. It is slightly transparent and red.
I need to make all clicks on the form pass through, as I will eventually make the form transparent and red, but I don't want the user to be able to interact with it.
Program is called "Red_Filter"
Public Class Form1
Dim Screens As Array
Dim TotalWidth As Integer
Dim TotalHeight As Integer
Dim Heights As List(Of Integer) = New List(Of Integer)
'Load / Close
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Screens = Screen.AllScreens
For I As Integer = 0 To UBound(Screens)
TotalWidth += Screens(I).Bounds.Width
Heights.Add(Screens(I).Bounds.Height)
Next
TotalHeight = Heights.Max()
Me.Width = TotalWidth
Me.Height = TotalWidth
Me.Location = New Point(0, 0)
Me.BackColor = Color.Red
Me.Opacity = 0.5
Me.TopMost = True
'Make it click through
SetWindowLong(Me.Handle, GWL_EXSTYLE, WS_EX_TRANSPARENT)
End Sub
'Click Through Functionality
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const GWL_EXSTYLE = -20
Const WS_EX_TRANSPARENT = &H20
End Class
This is what I have so far, the part after "'Click Through Functionality" I found online, however, it gives me this error:
A call to PInvoke function 'Red Filter!Red_Filter.Form1::SetWindowLong' has unbalanced the stack. This is likely because the managed PInvoke signature does not match the unmanaged target signature. Check that the calling convention and parameters of the PInvoke signature match the target unmanaged signature.
I do not know how the code I found online works, but the error happens in the last line of the form's load event.
Does anyone know how to make a form click-through?

I ripped code from this codeproject post: http://www.codeproject.com/Articles/12877/Transparent-Click-Through-Forms
Here's a complex version with all the comment-ey goodness:
Imports System.Runtime.InteropServices
Public Class Form1
Private InitialStyle As Integer
Dim PercentVisible As Decimal
Private Sub Form_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
' Grab the Extended Style information
' for this window and store it.
InitialStyle = GetWindowLong(Me.Handle, GWL.ExStyle)
PercentVisible = 0.8
' Set this window to Transparent
' (to the mouse that is!)
' This creates a new Extended Style
' for our window, which takes effect
' immediately upon being set, that
' combines the initial style of our window
' (saved in Form.Load) and adds the ability
' to be Transparent to the mouse.
' Both Layered and Transparent must be
' turned on for this to work AND have
' the window render properly!
SetWindowLong(Me.Handle, GWL.ExStyle, InitialStyle Or WS_EX.Layered Or WS_EX.Transparent)
' Don't forget to set the Alpha
' for the window or else you won't be able
' to see the window! Possible values
' are 0 (visibly transparent)
' to 255 (visibly opaque). I'll set
' it to 70% visible here for show.
' The second parameter is 0, because
' we're not using a ColorKey!
SetLayeredWindowAttributes(Me.Handle, 0, 255 * PercentVisible, LWA.Alpha)
' Just for giggles, set this window
' to stay on top of all others so we
' can see what's happening.
Me.TopMost = True
Me.BackColor = Color.Red
End Sub
Public Enum GWL As Integer
ExStyle = -20
End Enum
Public Enum WS_EX As Integer
Transparent = &H20
Layered = &H80000
End Enum
Public Enum LWA As Integer
ColorKey = &H1
Alpha = &H2
End Enum
<DllImport("user32.dll", EntryPoint:="GetWindowLong")> _
Public Shared Function GetWindowLong( _
ByVal hWnd As IntPtr, _
ByVal nIndex As GWL _
) As Integer
End Function
<DllImport("user32.dll", EntryPoint:="SetWindowLong")> _
Public Shared Function SetWindowLong( _
ByVal hWnd As IntPtr, _
ByVal nIndex As GWL, _
ByVal dwNewLong As WS_EX _
) As Integer
End Function
<DllImport("user32.dll", _
EntryPoint:="SetLayeredWindowAttributes")> _
Public Shared Function SetLayeredWindowAttributes( _
ByVal hWnd As IntPtr, _
ByVal crKey As Integer, _
ByVal alpha As Byte, _
ByVal dwFlags As LWA _
) As Boolean
End Function
End Class
And here's the simplified version I'm using that makes more sense to me:
Imports System.Runtime.InteropServices
Public Class Form1
Private InitialStyle As Integer
Dim PercentVisible As Decimal
Private Sub Form_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
InitialStyle = GetWindowLong(Me.Handle, -20)
PercentVisible = 0.8
SetWindowLong(Me.Handle, -20, InitialStyle Or &H80000 Or &H20)
SetLayeredWindowAttributes(Me.Handle, 0, 255 * PercentVisible, &H2)
Me.BackColor = Color.Red
Me.TopMost = True
End Sub
<DllImport("user32.dll", EntryPoint:="GetWindowLong")> Public Shared Function GetWindowLong(ByVal hWnd As IntPtr, ByVal nIndex As Integer) As Integer
End Function
<DllImport("user32.dll", EntryPoint:="SetWindowLong")> Public Shared Function SetWindowLong(ByVal hWnd As IntPtr, ByVal nIndex As Integer, ByVal dwNewLong As Integer) As Integer
End Function
<DllImport("user32.dll", EntryPoint:="SetLayeredWindowAttributes")> Public Shared Function SetLayeredWindowAttributes(ByVal hWnd As IntPtr, ByVal crKey As Integer, ByVal alpha As Byte, ByVal dwFlags As Integer) As Boolean
End Function
End Class

Try this:
Protected Overrides ReadOnly Property CreateParams() As CreateParams
Get
Const WS_EX_TRANSPARENT As Integer = &H20 'Check if it can
Dim params As CreateParams = MyBase.CreateParams
params.ExStyle = params.ExStyle Or WS_EX_TRANSPARENT
Return params 'return
End Get
End Property

Using VS 2012, I created a simple program without your Screens object, like this:
Public Class Form1
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Me.BackColor = Color.Red
Me.Opacity = 0.5
Me.TopMost = True
SetWindowLong(Me.Handle.ToInt64(), GWL_EXSTYLE, WS_EX_TRANSPARENT)
End Sub
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const GWL_EXSTYLE = -20
Const WS_EX_TRANSPARENT = &H20
End Class
Note the call to SetWindowLong:
SetWindowLong(Me.Handle.ToInt64(), GWL_EXSTYLE, WS_EX_TRANSPARENT)
Here's a screen shot of the program running:
EDITED TO ADD
Note that you can get this same effect without calling SetWindowLong.

Add this after Class:
Private Const WS_EX_TRANSPARENT As Integer = &H20
Protected Overrides ReadOnly Property CreateParams() As System.Windows.Forms.CreateParams
Get
Dim cp As CreateParams = MyBase.CreateParams
cp.ExStyle = cp.ExStyle Or WS_EX_TRANSPARENT
Return cp
End Get
End Property
Then run it. It should work. Also it dose not work on non-transparent forms from what i know.

A little variant for a ghost form (You can see through it and click through it!), with the most recent Declare syntax. Thanx to Postman for the useful post.
Imports System.Runtime.InteropServices
Public Class GhostForm
Private InitialStyle As Integer
Private PercentVisible As Decimal
Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As System.IntPtr, ByVal nIndex As Integer) As Integer
Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As System.IntPtr, ByVal nIndex As Integer, ByVal dwNewLong As Integer) As Integer
Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As IntPtr, ByVal crKey As Integer, ByVal alpha As Byte, ByVal dwFlags As Integer) As Boolean
Private Sub Form_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
InitialStyle = GetWindowLong(Me.Handle, -20)
PercentVisible = 0.5
SetWindowLong(Me.Handle, -20, InitialStyle Or &H80000 Or &H20)
SetLayeredWindowAttributes(Me.Handle, 0, 255 * PercentVisible, &H2)
Me.BackColor = Color.Green
Me.TopMost = True
End Sub
End Class

Related

Unable to find RECT size with DwmGetWindowAttribute

I'm trying to find to find the size of the cmd.exe window which is started as a child. I like to use this size to resize my form accordingly. For some reason the size returned by DwmGetWindowAttribute is always zero, so I must be doing something wrong here, but I can't find it. Any help will be greatly appreciated.
Kind regards,
Eric
Imports System.Runtime.InteropServices
Public Class Form1
Private WithEvents Tmr As New Timer With {.Interval = 100}
Private Const HWND_BOTTOM As Integer = &H1
Private WithEvents proc As New Process
Public Const DWMWA_EXTENDED_FRAME_BOUNDS As Integer = 9
<DllImport("user32.dll", EntryPoint:="SetParent")>
Private Shared Function SetParent(ByVal hWndChild As IntPtr, ByVal hWndNewParent As IntPtr) As IntPtr
End Function
<DllImport("user32.dll", EntryPoint:="SetWindowPos")>
Private Shared Function SetWindowPos(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 uFlags As UInteger) As <MarshalAs(UnmanagedType.Bool)> Boolean
End Function
<DllImport("dwmapi.dll")>
Shared Function DwmGetWindowAttribute(ByVal hwnd As IntPtr, ByVal dwAttribute As Integer, ByRef pvAttribute As RECT, ByVal cbAttribute As Integer) As Integer
End Function
Public Structure RECT
Public left, top, right, bottom As Integer
End Structure
Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Load
Me.Text = "My title"
proc.EnableRaisingEvents = True
proc.StartInfo.FileName = "cmd"
proc.Start()
Tmr.Start()
End Sub
Private Sub Tmr_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles Tmr.Tick
If SetParent(proc.MainWindowHandle, Panel1.Handle) <> IntPtr.Zero Then
Tmr.Stop()
Dim Width As Integer
Dim Hight As Integer
Dim WindowRect As New RECT
DwmGetWindowAttribute(proc.MainWindowHandle, DWMWA_EXTENDED_FRAME_BOUNDS, WindowRect, Marshal.SizeOf(WindowRect))
Width = WindowRect.right - WindowRect.left
Hight = WindowRect.bottom - WindowRect.top
MessageBox.Show("Hight: " & Hight & " Width: " & Width)
'Me.Size = New Size(Width, Hight)
SetWindowPos(proc.MainWindowHandle, New IntPtr(HWND_BOTTOM), 0, 0, Panel1.ClientSize.Width, Panel1.ClientSize.Height, 0)
End If
End Sub
Private Sub Proc_Exited(ByVal sender As Object, ByVal e As System.EventArgs) Handles proc.Exited
Invoke(Sub() Close())
End Sub
End Class
After implementing all valuable additions of #Jimi, this is the code that works:
Imports System.Runtime.InteropServices
Public Class Form1
Private WithEvents proc As New Process
Public Const WM_NCLBUTTONDOWN As Long = &HA1
Public Const SW_SHOWMAXIMIZED As UInt32 = 3
Public Const WM_CLOSE = &H10
Public Const DWMWA_EXTENDED_FRAME_BOUNDS As Integer = 9
'Function to set the parent window
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As IntPtr, ByVal hWndNewParent As IntPtr) As IntPtr
'Function to set the child window position
Private 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 uFlags As UInteger) As <MarshalAs(UnmanagedType.Bool)> Boolean
'Function to allow the child to be maximized
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As IntPtr, ByVal nCmdShow As Int32) As Boolean
'Function to retrieve the initail child size
Private Declare Function DwmGetWindowAttribute Lib "dwmapi" (ByVal hwnd As IntPtr, ByVal dwAttribute As Integer, ByRef pvAttribute As RECT, ByVal cbAttribute As Integer) As Integer
'Function to set focus to the child window
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As IntPtr) As Long
'Function used to set terminate child window
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As IntPtr, ByVal wMsg As Integer, ByVal wParam As Integer, ByVal lParam As Integer) As Integer
'Rectangle size, used later to resize the form
Public Structure RECT
Public left, top, right, bottom As Integer
End Structure
Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Load
Me.Text = "My title"
proc.EnableRaisingEvents = True
proc.StartInfo.FileName = "cmd"
proc.Start()
End Sub
Private Sub Tmr_Tick(ByVal sender As Object, ByVal e As System.EventArgs) Handles MyBase.Shown
'Wait for 200 ms for the form to load
proc.WaitForExit(200)
Dim WindowRect As New RECT
Dim Width, Hight As Integer
'Retrieve the initial size of the child window
DwmGetWindowAttribute(proc.MainWindowHandle, DWMWA_EXTENDED_FRAME_BOUNDS, WindowRect, Marshal.SizeOf(WindowRect))
Width = WindowRect.right - WindowRect.left
Hight = WindowRect.bottom - WindowRect.top + 23
'Set the form size to the initial size of the child window
Me.Size = New Size(Width, Hight)
'When the child is started, move the child into the panel and maximize it
If SetParent(proc.MainWindowHandle, Panel1.Handle) <> IntPtr.Zero Then
SetWindowPos(proc.MainWindowHandle, IntPtr.Zero, 0, 0, Width, Height, 0)
ShowWindow(proc.MainWindowHandle, SW_SHOWMAXIMIZED)
End If
End Sub
'Exit form when child terminates
Private Sub Proc_Exited(ByVal sender As Object, ByVal e As System.EventArgs) Handles proc.Exited
Invoke(Sub() Close())
End Sub
'Set focus on child when the form is activated
Private Sub Form1_UnFocus(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Activated
SetForegroundWindow(proc.MainWindowHandle)
End Sub
'Set focus on child when the parent titlebar is clicked
Protected Overrides Sub DefWndProc(ByRef m As System.Windows.Forms.Message)
If CLng(m.Msg) = WM_NCLBUTTONDOWN Then
SetForegroundWindow(proc.MainWindowHandle)
End If
MyBase.DefWndProc(m)
End Sub
'Properly terminate child when the form is closed by the user
Private Sub Form1_Closed(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Closed
SendMessage(proc.MainWindowHandle, WM_CLOSE, 0, 0)
End Sub
End Class
Kind regards,
Eric

SystemMenu add click event

I have a code that append menu in the system menu(right click form title bar). How will i add click event in the two menus that i appended? this is the code i use:
Public Class AppendFormSysMenu
<DllImport("user32.dll", CharSet:=CharSet.Auto, SetLastError:=True)>
Private Shared Function AppendMenu(ByVal hMenu As IntPtr, ByVal uFlags As Int32, ByVal uIDNewItem As IntPtr, ByVal lpNewItem As String) As Boolean
End Function
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As IntPtr, ByVal bRevert As Boolean) As IntPtr
Private SYSMENU_SAVE_FORM_ID As Integer = &H1
Private SYSMENU_RESTORE_FORM_ID As Integer = &H2
<Flags()>
Public Enum MenuFlags As Integer
MF_BYPOSITION = 1024
MF_REMOVE = 4096
MF_SEPARATOR = 2048
MF_STRING = 0
End Enum
Public Sub insertSeparator(frm As Form)
Dim hMenu = GetSystemMenu(frm.Handle, False)
AppendMenu(hMenu, MenuFlags.MF_SEPARATOR, 0, Nothing)
End Sub
Public Sub insertSaveMenu(frm As Form, ByVal strMenuItem As String)
Dim hMenu = GetSystemMenu(frm.Handle, False)
AppendMenu(hMenu, MenuFlags.MF_STRING, SYSMENU_SAVE_FORM_ID, strMenuItem)
End Sub
Public Sub insertRestoreMenu(frm As Form, ByVal strMenuItem As String)
Dim hMenu = GetSystemMenu(frm.Handle, False)
AppendMenu(hMenu, MenuFlags.MF_STRING, SYSMENU_RESTORE_FORM_ID, strMenuItem)
End Sub
End Class
This is the code i use in the form:
Dim AppendFormMenu As New AppendFormSysMenu
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
AppendFormMenu.insertSeparator(Me)
AppendFormMenu.insertSaveMenu(Me, "Save Form Position")
AppendFormMenu.insertRestoreMenu(Me, "Restore Form Position")
End Sub

Microsoft Multipoint SDK not registering (VB.NET)

All the Microsoft tutorials are in C#, but I'm usually pretty good at converting between. However, I cannot solve this for the life of me. How do I convert Multipointsdk.Instance.Register(this); into VB.NET? My first shot was MultipointSdk.Instance.Register(Me) but it won't let me cast "Me" to a Window type. Code below:
Imports System.Runtime.InteropServices
Imports Microsoft.Multipoint.Sdk
Public Class Form1
Private InitialStyle As Integer
Dim PercentVisible As Decimal
Private Sub Form_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
InitialStyle = GetWindowLong(Me.Handle, -20)
PercentVisible = 0.8
SetWindowLong(Me.Handle, -20, InitialStyle Or &H80000 Or &H20)
SetLayeredWindowAttributes(Me.Handle, 0, 255 * PercentVisible, &H2)
Me.BackColor = Color.Red
Me.TopMost = True
MultipointSdk.Instance.Register(Me)
End Sub
<DllImport("user32.dll", EntryPoint:="GetWindowLong")> Public Shared Function GetWindowLong(ByVal hWnd As IntPtr, ByVal nIndex As Integer) As Integer
End Function
<DllImport("user32.dll", EntryPoint:="SetWindowLong")> Public Shared Function SetWindowLong(ByVal hWnd As IntPtr, ByVal nIndex As Integer, ByVal dwNewLong As Integer) As Integer
End Function
<DllImport("user32.dll", EntryPoint:="SetLayeredWindowAttributes")> Public Shared Function SetLayeredWindowAttributes(ByVal hWnd As IntPtr, ByVal crKey As Integer, ByVal alpha As Byte, ByVal dwFlags As Integer) As Boolean
End Function
End Class

VB.Net api affects windows forms

I am creating a application in vb.net and i am using some API functions.For example : GetForegroundWindow,SetWindowPos .So my app should change the active window's size and position when clicked.But it is affecting also the system forms like taskbar , StartMenu.How can i avoid this?
<Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function SetWindowPos(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 uFlags As Integer) As Integer
End Function ''SETTTING THE WINDOW POSITION
<Runtime.InteropServices.DllImport("user32.dll")> _
Shared Function GetAsyncKeyState(ByVal vKey As System.Windows.Forms.Keys) As Short
End Function
<Runtime.InteropServices.DllImport("user32.dll", SetLastError:=True)> _
Private Shared Function GetForegroundWindow() As IntPtr
End Function
Private ReadOnly HWND_TOP As New IntPtr(0)
Public Const SWP_FRAMECHANGED As Integer = &H20
Dim cX As Integer, cY As Integer
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
cX = CInt(Windows.Forms.Cursor.Position.X.ToString())
cY = CInt(Windows.Forms.Cursor.Position.Y.ToString())
If GetAsyncKeyState(1) <> 0 Then
If cX <= 10 Then
If GetForegroundWindow() <> 1 Then
SetWindowPos(GetForegroundWindow(), HWND_TOP, 0, 0, 100, 100, SWP_FRAMECHANGED)
End If
End If
End If
End Sub
<Runtime.InteropServices.DllImport("User32")>
Public Shared Function GetWindowThreadProcessId(hWnd As IntPtr, ByRef lpdwProcessId As IntPtr) As IntPtr
End Function
Private Sub Button1_Click() Handles Button1.Click
Dim ID As IntPtr, hWnd As IntPtr '// hWnd By GetForegroundWindow
GetWindowThreadProcessId(hWnd, ID)
If Process.GetProcessById(ID).ProcessName.ToLower <> "Explorer".ToLower Then 'Without.exe
MessageBox.Show("Set Position")
End If
End Sub

How to put a button on the forms top bar

Using VB.Net 2012
I would like to put a command button on the of my windows form to the left of the control box and to the right of the title. Is this possible?
I don't see a way of doing this through the 'standard' windows means perhaps with some more advanced GDI trickery?
I was going to add a picture of what I am trying to accomplish but apparently my reputation is too low to post images, I will try an ascii picture, please use your imagination!
________________________________________________________
|Q Windows Title [New BUTTON] [ _ O X ] |
|______________________________________________________|
| |
| Normal windows area |
It has some work but can be done. Create a new class APIHelp:
Imports System.Runtime.InteropServices
Public Class APIHelp
Public Const WS_EX_LAYERED As Int32 = 524288
'Public Const HTCAPTION As Int32 = 2
'Public Const WM_NCHITTEST As Int32 = 132
Public Const ULW_ALPHA As Int32 = 2
Public Const AC_SRC_OVER As Byte = 0
Public Const AC_SRC_ALPHA As Byte = 1
Public Enum Bool
[False] = 0
[True] = 1
End Enum
<StructLayout(LayoutKind.Sequential)> _
Public Structure Point
Public x As Int32
Public y As Int32
Public Sub New(ByVal x As Int32, ByVal y As Int32)
Me.x = x
Me.y = y
End Sub
End Structure
<StructLayout(LayoutKind.Sequential)> _
Public Structure Size
Public cx As Int32
Public cy As Int32
Public Sub New(ByVal cx As Int32, ByVal cy As Int32)
Me.cx = cx
Me.cy = cy
End Sub
End Structure
<StructLayout(LayoutKind.Sequential, Pack:=1)> _
Private Structure ARGB
Public Blue As Byte
Public Green As Byte
Public Red As Byte
Public Alpha As Byte
End Structure
<StructLayout(LayoutKind.Sequential, Pack:=1)> _
Public Structure BLENDFUNCTION
Public BlendOp As Byte
Public BlendFlags As Byte
Public SourceConstantAlpha As Byte
Public AlphaFormat As Byte
End Structure
Public Declare Auto Function UpdateLayeredWindow Lib "user32.dll" (ByVal hwnd As IntPtr, ByVal hdcDst As IntPtr, ByRef pptDst As Point, ByRef psize As Size, ByVal hdcSrc As IntPtr, ByRef pprSrc As Point, _
ByVal crKey As Int32, ByRef pblend As BLENDFUNCTION, ByVal dwFlags As Int32) As Bool
Public Declare Auto Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As IntPtr) As IntPtr
Public Declare Auto Function GetDC Lib "user32.dll" (ByVal hWnd As IntPtr) As IntPtr
<DllImport("user32.dll", ExactSpelling:=True)> _
Public Shared Function ReleaseDC(ByVal hWnd As IntPtr, ByVal hDC As IntPtr) As Integer
End Function
Public Declare Auto Function DeleteDC Lib "gdi32.dll" (ByVal hdc As IntPtr) As Bool
<DllImport("gdi32.dll", ExactSpelling:=True)> _
Public Shared Function SelectObject(ByVal hDC As IntPtr, ByVal hObject As IntPtr) As IntPtr
End Function
Public Declare Auto Function DeleteObject Lib "gdi32.dll" (ByVal hObject As IntPtr) As Bool
End Class
Add a new form eg Form2. Set TopMost = False, FormBorderStyle = None and
ShowInTaskbar = False. This form will be your button. Because we want to draw tranparently we set the WS_EX_LAYERED style and we draw
with UpdateLayeredWindow function. You can not draw directly on a form with WS_EX_LAYERED style.
You have to use a device context, draw in it and then call UpdateLayeredWindow:
Public Class Form2
Private sourceLocation As New APIHelp.Point(0, 0)
Private newSize As New APIHelp.Size(...., .....)
Private newLocation As APIHelp.Point
Private blend As New APIHelp.BLENDFUNCTION()
Private memDcNormal, memDcEnter, memDcDown, screenDc, hBmpNormal, hBmpNormalOld, _
hBmpEnter, hBmpEnterOld, hBmpDown, hBmpDownOld As IntPtr
Private Sub Form2_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Me.Location = New Point(Form1.Location.X + ..., Form1.Location.Y + ...) 'complete the dots
Me.Size = New Size(..., ...) 'size of button
Initialize()
End Sub
Private Sub Initialize()
' Only works with a 32bpp bitmap
blend.BlendOp = APIHelp.AC_SRC_OVER
' Always 0
blend.BlendFlags = 0
' Set to 255 for per-pixel alpha values
blend.SourceConstantAlpha = 255
' Only works when the bitmap contains an alpha channel
blend.AlphaFormat = APIHelp.AC_SRC_ALPHA
screenDc = APIHelp.GetDC(IntPtr.Zero)
Using bmp As Bitmap = CType(Bitmap.FromFile(".....Normal.png"), Bitmap)
memDcNormal = IntPtr.Zero
memDcNormal = APIHelp.CreateCompatibleDC(screenDc)
hBmpNormal = bmp.GetHbitmap(Color.FromArgb(0))
hBmpNormalOld = APIHelp.SelectObject(memDcNormal, hBmpNormal)
End Using
Using bmp As Bitmap = CType(Bitmap.FromFile("......Enter.png"), Bitmap)
memDcEnter = IntPtr.Zero
memDcEnter = APIHelp.CreateCompatibleDC(screenDc)
hBmpEnter = bmp.GetHbitmap(Color.FromArgb(0))
hBmpEnterOld = APIHelp.SelectObject(memDcEnter, hBmpEnter)
End Using
Using bmp As Bitmap = CType(Bitmap.FromFile("......Down.png"), Bitmap)
memDcDown = IntPtr.Zero
memDcDown = APIHelp.CreateCompatibleDC(screenDc)
hBmpDown= bmp.GetHbitmap(Color.FromArgb(0))
hBmpDownOld = APIHelp.SelectObject(memDcDown, hBmpDown)
End Using
APIHelp.DeleteDC(screenDc)
End Sub
Protected Overloads Overrides ReadOnly Property CreateParams() As CreateParams
Get
'Add the layered extended style (WS_EX_LAYERED) to this window
Dim createParam As CreateParams = MyBase.CreateParams
createParam.ExStyle = createParam.ExStyle Or 524288 'WS_EX_LAYERED
Return createParam
End Get
End Property
Private Sub Form2_MouseDown(sender As System.Object, e As System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseDown
newLocation = New APIHelp.Point(Me.Location.X, Me.Location.Y)
APIHelp.UpdateLayeredWindow(Handle, IntPtr.Zero, newLocation, newSize, memDcDown, sourceLocation, _
0, blend, APIHelp.ULW_ALPHA)
End Sub
Private Sub Form2_MouseEnter(sender As System.Object, e As System.EventArgs) Handles MyBase.MouseEnter
newLocation = New APIHelp.Point(Me.Location.X, Me.Location.Y)
APIHelp.UpdateLayeredWindow(Handle, IntPtr.Zero, newLocation, newSize, memDcEnter, sourceLocation, _
0, blend, APIHelp.ULW_ALPHA)
End Sub
Private Sub Form2_MouseMove(sender As System.Object, e As System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseMove
Static i As Integer = 1
Static j As Integer = 1
If e.Button = Windows.Forms.MouseButtons.Left Then
If e.X < 0 Or e.X > Me.Width Or e.Y < 0 Or e.Y > Me.Height Then
If i = 1 Then
newLocation = New APIHelp.Point(Me.Location.X, Me.Location.Y)
APIHelp.UpdateLayeredWindow(Handle, IntPtr.Zero, newLocation, newSize, memDcNormal, sourceLocation, _
0, blend, APIHelp.ULW_ALPHA)
i = 0
j = 1
End If
Else
If j = 1 Then
newLocation = New APIHelp.Point(Me.Location.X, Me.Location.Y)
APIHelp.UpdateLayeredWindow(Handle, IntPtr.Zero, newLocation, newSize, memDcDown, sourceLocation, _
0, blend, APIHelp.ULW_ALPHA)
j = 0
i = 1
End If
End If
End If
End Sub
Private Sub Form2_MouseLeave(sender As System.Object, e As System.EventArgs) Handles MyBase.MouseLeave
newLocation = New APIHelp.Point(Me.Location.X, Me.Location.Y)
APIHelp.UpdateLayeredWindow(Handle, IntPtr.Zero, newLocation, newSize, memDcNormal, sourceLocation, _
0, blend, APIHelp.ULW_ALPHA)
End Sub
Private Sub Form2_MouseClick(sender As System.Object, e As System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseClick
newLocation = New APIHelp.Point(Me.Location.X, Me.Location.Y)
APIHelp.UpdateLayeredWindow(Handle, IntPtr.Zero, newLocation, newSize, memDcEnter, sourceLocation, _
0, blend, APIHelp.ULW_ALPHA)
'Do your staff
End Sub
Private Sub Form2_FormClosing(sender As System.Object, e As System.Windows.Forms.FormClosingEventArgs) Handles MyBase.FormClosing
APIHelp.SelectObject(memDcNormal, hBmpNormalOld)
APIHelp.DeleteObject(hBmpNormal)
APIHelp.DeleteDC(memDcNormal)
APIHelp.SelectObject(memDcEnter, hBmpEnterOld)
APIHelp.DeleteObject(hBmpEnter)
APIHelp.DeleteDC(memDcEnter)
APIHelp.SelectObject(memDcDown, hBmpDownOld)
APIHelp.DeleteObject(hBmpDown)
APIHelp.DeleteDC(memDcDown)
End Sub
End Class
As you can see from the above code you need three png images for each state of the button.
In your initial form:
Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Form2.Show(Me)
End Sub
Private Sub Form1_Move(sender As System.Object, e As System.EventArgs) Handles MyBase.Move
Form2.Location = New Point(Me.Location.X + ..., Me.Location.Y + ...)
End Sub
valter