Imports System
Imports System.Drawing
Imports System.Windows.Forms
Imports System.Runtime.InteropServices
Imports System.Windows.Forms.VisualStyles
Public Class rtaGlassEffect
Public WithEvents ParentForm As Form
Private mHeaderImage As PictureBox
Public Property HeaderImage() As PictureBox
Get
Return mHeaderImage
End Get
Set(ByVal value As PictureBox)
mHeaderImage = value
End Set
End Property
Private mTopBarSize As Integer
Public Property TopBarSize() As Integer
Get
Return mTopBarSize
End Get
Set(ByVal value As Integer)
mTopBarSize = value
End Set
End Property
Private mBottomBarSize As Integer
Public Property BottomBarSize() As Integer
Get
Return mBottomBarSize
End Get
Set(ByVal value As Integer)
mBottomBarSize = value
End Set
End Property
Private mLeftBarSize As Integer
Public Property LeftBarSize() As Integer
Get
Return mLeftBarSize
End Get
Set(ByVal value As Integer)
mLeftBarSize = value
End Set
End Property
Private mRightBarSize As Integer
Public Property RightBarSize() As Integer
Get
Return mRightBarSize
End Get
Set(ByVal value As Integer)
mRightBarSize = value
End Set
End Property
Private mHeaderLabel As Label
Public Property HeaderLabel() As Label
Get
Return mHeaderLabel
End Get
Set(ByVal value As Label)
mHeaderLabel = value
End Set
End Property
Private mUseHandCursorOnTitle As Boolean = True
Property UseHandCursorOnTitle() As Boolean
Get
Return mUseHandCursorOnTitle
End Get
Set(ByVal value As Boolean)
mUseHandCursorOnTitle = value
End Set
End Property
Public Sub ShowEffect(ByVal Parent As Form, ByVal HeaderLabel As Label, ByVal HeaderImage As PictureBox)
Me.ParentForm = Parent
Me.HeaderLabel = HeaderLabel
Me.HeaderImage = HeaderImage
SetGlassEffect(Me.ParentForm, mTopBarSize, mRightBarSize, mBottomBarSize, mLeftBarSize)
End Sub
Public Sub ShowEffect(ByVal Parent As Form, ByVal HeaderLabel As Label)
Me.ParentForm = Parent
Me.HeaderLabel = HeaderLabel
SetGlassEffect(Me.ParentForm, mTopBarSize, mRightBarSize, mBottomBarSize, mLeftBarSize)
End Sub
Public Sub ShowEffect(ByVal Parent As Form, ByVal HeaderImage As PictureBox)
Me.ParentForm = Parent
Me.HeaderImage = HeaderImage
SetGlassEffect(Me.ParentForm, mTopBarSize, mRightBarSize, mBottomBarSize, mLeftBarSize)
End Sub
Public Sub ShowEffect(ByVal Parent As Form)
Me.ParentForm = Parent
SetGlassEffect(Me.ParentForm, mTopBarSize, mRightBarSize, mBottomBarSize, mLeftBarSize)
End Sub
Public Function SetGlassEffect(Optional ByVal fromTop As Integer = 0, Optional ByVal fromRight As Integer = 0, Optional ByVal fromBottom As Integer = 0, Optional ByVal fromLeft As Integer = 0) As Boolean
SetGlassEffect(Me.ParentForm, fromTop, fromRight, fromBottom, fromLeft)
Me.ParentForm.Invalidate()
End Function
Public Shared ReadOnly Property GlassEnabled() As Boolean
Get
Dim VistaOrAbove As Boolean = (Environment.OSVersion.Version.Major >= 6)
If VistaOrAbove Then
Dim Enabled As Boolean
APIs.DwmIsCompositionEnabled(Enabled)
Return Enabled
Else
Return False
End If
End Get
End Property
Public Shared Function SetGlassEffect(ByVal Frm As Form, Optional ByVal fromTop As Integer = 0, Optional ByVal fromRight As Integer = 0, Optional ByVal fromBottom As Integer = 0, Optional ByVal fromLeft As Integer = 0) As Boolean
If rtaGlassEffect.GlassEnabled AndAlso Frm IsNot Nothing Then
Dim m As New APIs.MARGINS
m.Top = fromTop
m.Right = fromRight
m.Left = fromLeft
m.Bottom = fromBottom
APIs.DwmExtendFrameIntoClientArea(Frm.Handle, m)
Frm.Invalidate()
End If
End Function
Public Shared Sub DrawTextGlow(ByVal Graphics As Graphics, ByVal text As String, ByVal fnt As Font, ByVal bounds As Rectangle, ByVal Clr As Color, ByVal flags As TextFormatFlags)
Dim SavedBitmap As IntPtr = IntPtr.Zero
Dim SavedFont As IntPtr = IntPtr.Zero
Dim MainHDC As IntPtr = Graphics.GetHdc
Dim MemHDC As IntPtr = APIs.CreateCompatibleDC(MainHDC)
Dim BtmInfo As New APIs.BITMAPINFO
Dim TextRect As New APIs.RECT(0, 0, bounds.Right - bounds.Left + 2 * 15, bounds.Bottom - bounds.Top + 2 * 15)
Dim ScreenRect As New APIs.RECT(bounds.Left - 15, bounds.Top - 15, bounds.Right + 15, bounds.Bottom + 15)
Dim hFont As IntPtr = fnt.ToHfont
BtmInfo.bmiHeader.biSize = Marshal.SizeOf(BtmInfo.bmiHeader)
With BtmInfo
.bmiHeader.biWidth = bounds.Width + 30
.bmiHeader.biHeight = -bounds.Height - 30
.bmiHeader.biPlanes = 1
.bmiHeader.biBitCount = 32
End With
Dim dibSection As IntPtr = APIs.CreateDIBSection(MainHDC, BtmInfo, 0, 0, IntPtr.Zero, 0)
SavedBitmap = APIs.SelectObject(MemHDC, dibSection)
SavedFont = APIs.SelectObject(MemHDC, hFont)
Dim TextOptions As APIs.S_DTTOPTS = New APIs.S_DTTOPTS
With TextOptions
.dwSize = Marshal.SizeOf(TextOptions)
.dwFlags = APIs.DTT_COMPOSITED Or APIs.DTT_GLOWSIZE Or APIs.DTT_TEXTCOLOR
.crText = ColorTranslator.ToWin32(Clr)
.iGlowSize = 18
End With
Dim Renderer As VisualStyleRenderer = New VisualStyleRenderer(System.Windows.Forms.VisualStyles.VisualStyleElement.Window.Caption.Active)
APIs.DrawThemeTextEx(Renderer.Handle, MemHDC, 0, 0, text, -1, flags, TextRect, TextOptions)
With ScreenRect
APIs.BitBlt(MainHDC, .Left, .Top, .Right - .Left, .Bottom - .Top, MemHDC, 0, 0, APIs.SRCCOPY)
End With
APIs.SelectObject(MemHDC, SavedFont)
APIs.SelectObject(MemHDC, SavedBitmap)
APIs.DeleteDC(MemHDC)
APIs.DeleteObject(hFont)
APIs.DeleteObject(dibSection)
Graphics.ReleaseHdc(MainHDC)
End Sub
Public Class APIs
Public Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As IntPtr, ByRef pbmi As BITMAPINFO, ByVal iUsage As UInt32, ByVal ppvBits As Integer, ByVal hSection As IntPtr, ByVal dwOffset As UInt32) As IntPtr
Public Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As IntPtr) As IntPtr
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As IntPtr, ByVal hObject As IntPtr) As IntPtr
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As IntPtr) As Boolean
Public Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As IntPtr) As Boolean
Public Declare Function BitBlt Lib "gdi32.dll" (ByVal hdc As IntPtr, ByVal nXDest As Integer, ByVal nYDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hdcSrc As IntPtr, ByVal nXSrc As Integer, ByVal nYSrc As Integer, ByVal dwRop As Int32) As Boolean
Public Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi.dll" (ByVal hWnd As IntPtr, ByRef margins As MARGINS) As Integer
Public Declare Sub DwmIsCompositionEnabled Lib "dwmapi.dll" (ByRef IsIt As Boolean)
<DllImport("UxTheme.dll", ExactSpelling:=True, SetLastError:=True, CharSet:=CharSet.Unicode)> Shared Function DrawThemeTextEx(ByVal hTheme As IntPtr, ByVal hdc As IntPtr, ByVal iPartId As Integer, ByVal iStateId As Integer, ByVal text As String, ByVal iCharCount As Integer, ByVal dwFlags As Integer, ByRef pRect As RECT, ByRef pOptions As S_DTTOPTS) As Integer
End Function
Public Const DTT_COMPOSITED As Integer = 8192
Public Const DTT_GLOWSIZE As Integer = 2048
Public Const DTT_TEXTCOLOR As Integer = 1
Public Const SRCCOPY As Integer = &HCC0020
<StructLayout(LayoutKind.Sequential)> _
Public Structure MARGINS
Public Left As Integer
Public Right As Integer
Public Top As Integer
Public Bottom As Integer
End Structure
Public Structure RECT
Public Sub New(ByVal iLeft As Integer, ByVal iTop As Integer, ByVal iRight As Integer, ByVal iBottom As Integer)
Left = iLeft
Top = iTop
Right = iRight
Bottom = iBottom
End Sub
Public Left As Integer
Public Top As Integer
Public Right As Integer
Public Bottom As Integer
End Structure
Public Structure BITMAPINFOHEADER
Dim biSize As Integer
Dim biWidth As Integer
Dim biHeight As Integer
Dim biPlanes As Short
Dim biBitCount As Short
Dim biCompression As Integer
Dim biSizeImage As Integer
Dim biXPelsPerMeter As Integer
Dim biYPelsPerMeter As Integer
Dim biClrUsed As Integer
Dim biClrImportant As Integer
End Structure
Public Structure RGBQUAD
Dim rgbBlue As Byte
Dim rgbGreen As Byte
Dim rgbRed As Byte
Dim rgbReserved As Byte
End Structure
Public Structure BITMAPINFO
Dim bmiHeader As BITMAPINFOHEADER
Dim bmiColors As RGBQUAD
End Structure
Public Structure S_DTTOPTS
Dim dwSize As Integer
Dim dwFlags As Integer
Dim crText As Integer
Dim crBorder As Integer
Dim crShadow As Integer
Dim iTextShadowType As Integer
Dim ptShadowOffset As Point
Dim iBorderSize As Integer
Dim iFontPropId As Integer
Dim iColorPropId As Integer
Dim iStateId As Integer
Dim fApplyOverlay As Boolean
Dim iGlowSize As Integer
Dim pfnDrawTextCallback As Integer
Dim lParam As IntPtr
End Structure
End Class
Private Sub Parent_Paint(ByVal sender As Object, ByVal e As System.Windows.Forms.PaintEventArgs) Handles ParentForm.Paint
If mTopBarSize > 0 Then
e.Graphics.FillRectangle(Brushes.Black, New Rectangle(0, 0, Me.ParentForm.ClientSize.Width, mTopBarSize))
End If
If mBottomBarSize > 0 Then
e.Graphics.FillRectangle(Brushes.Black, New Rectangle(0, Me.ParentForm.ClientSize.Height - mBottomBarSize, Me.ParentForm.ClientSize.Width, mBottomBarSize))
End If
If mRightBarSize > 0 Then
e.Graphics.FillRectangle(Brushes.Black, New Rectangle(Me.ParentForm.ClientSize.Width - mRightBarSize, 0, mRightBarSize, Me.ParentForm.ClientSize.Height))
End If
If mLeftBarSize > 0 Then
e.Graphics.FillRectangle(Brushes.Black, New Rectangle(0, 0, mLeftBarSize, Me.ParentForm.ClientSize.Height))
End If
If (HeaderLabel IsNot Nothing) AndAlso (HeaderLabel.Text.Length > 0) Then
HeaderLabel.Visible = False
rtaGlassEffect.DrawTextGlow(e.Graphics, HeaderLabel.Text, HeaderLabel.Font, HeaderLabel.Bounds, HeaderLabel.ForeColor, TextFormatFlags.VerticalCenter Or TextFormatFlags.HorizontalCenter Or TextFormatFlags.NoPrefix Or TextFormatFlags.SingleLine)
End If
If (Me.HeaderImage IsNot Nothing) AndAlso (Me.HeaderImage.Image IsNot Nothing) Then
HeaderImage.Visible = False
e.Graphics.DrawImage(mHeaderImage.Image, mHeaderImage.Bounds)
End If
End Sub
Private Last As Point = Point.Empty
Private Sub Parent_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles ParentForm.MouseDown
If e.Location.Y <= mTopBarSize Then
Last = e.Location
Else
Last = Point.Empty
End If
End Sub
Private Sub Parent_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles ParentForm.MouseMove
If (Not Last.Equals(Point.Empty)) AndAlso (e.Button = Windows.Forms.MouseButtons.Left) Then
ParentForm.Location = New Point(ParentForm.Left + e.Location.X - Last.X, ParentForm.Top + e.Location.Y - Last.Y)
End If
If mUseHandCursorOnTitle Then
If (e.Location.Y < mTopBarSize) Then
If Not ParentForm.Cursor.Equals(Cursors.Hand) Then ParentForm.Cursor = Cursors.Hand
ElseIf Not ParentForm.Cursor.Equals(Cursors.Default) Then
ParentForm.Cursor = Cursors.Default
End If
End If
End Sub
End Class