VB net Custom Border and Background Opacity

Lnguage: VB net (NetFramework 4.0) (will work in NetFramework 3.5 or before)

To make Forms with Custom Appearance, but standard Behaviour This program use the following dll:

• user32.dll
• uxtheme.dll
• gdi32.dll

The following dll is on the Windows System by default, you don't need to download the dll again, exept your system is missing the files.
With Windows API in the dll, Program will use the following method/function:

• CreateCompatibleDC
• UpdateLayeredWindow
• DeleteDC
• DeleteObject
• GetDC
• GetScrollBarInfo
• SelectObject
• SetWindowTheme

This The Code Of The Sample Program:

Imports System
Imports System.Drawing
Imports System.Windows.Forms
Imports System.Runtime.InteropServices
Imports System.Drawing.Imaging
Imports System.Drawing.Drawing2D
Partial Public Class Form1
  Public Sub New()
    InitializeComponent()
    AddPaintHandlers(Me)
  End Sub
  Protected Overrides ReadOnly Property CreateParams() As CreateParams
    Get
      Dim cp As CreateParams = MyBase.CreateParams
      If Not Me.DesignMode Then
        cp.ExStyle = cp.ExStyle Or NativeMethods.WS_EX_LAYERED
      End If
      Return cp
    End Get
  End Property
  Protected Overrides Sub CreateHandle()
    MyBase.CreateHandle()
    'Disable VisualStyles as we're doing all painting ourselves.
    If OSFeature.Feature.IsPresent(OSFeature.Themes) Then
      NativeMethods.SetWindowTheme(Me.Handle, Nothing, "")
    End If
  End Sub
  Protected Overrides Sub OnResize(ByVal e As EventArgs)
    MyBase.OnResize(e)
    If Me.Created Then
      UpdateWindow()
    End If
  End Sub
  Protected Overrides Sub OnLocationChanged(ByVal e As EventArgs)
    MyBase.OnLocationChanged(e)
    If Me.Created Then
      UpdateWindow()
    End If
  End Sub
  Protected Overrides Sub OnVisibleChanged(ByVal e As EventArgs)
    MyBase.OnVisibleChanged(e)
    If Me.Visible Then
      UpdateWindow()
    End If
  End Sub
  Protected Overrides Sub OnScroll(ByVal se As ScrollEventArgs)
    MyBase.OnScroll(se)
    If (Me.Created) Then
      Me.UpdateWindow()
    End If
  End Sub
  Private Sub AddPaintHandlers(ByVal control As Control)
    For Each ctl As Control In control.Controls
      AddHandler ctl.MouseEnter, AddressOf ctl_Paint
      AddHandler ctl.MouseLeave, AddressOf ctl_Paint
      AddHandler ctl.MouseDown, AddressOf ctl_Paint
      AddHandler ctl.MouseUp, AddressOf ctl_Paint
      AddHandler ctl.MouseMove, AddressOf ctl_Paint
      AddPaintHandlers(ctl)
    Next
  End Sub
  Private Sub ctl_Paint(ByVal sender As Object, ByVal e As EventArgs)
    Me.UpdateWindow()
  End Sub
  Public Sub UpdateWindow()
    If (Me.IsDisposed OrElse Me.Width <= 0 OrElse Me.Height <= 0) Then
      Return
    End If
    Using backBuffer As New Bitmap(Me.Width, Me.Height, PixelFormat.Format32bppPArgb)
      Using gr As Graphics = Graphics.FromImage(backBuffer)
        gr.SmoothingMode = SmoothingMode.AntiAlias
        Dim pt As Point = Me.PointToScreen(Point.Empty)
        pt.Offset(-Me.Left, -Me.Top)
        Dim rc As Rectangle = Me.RectangleToScreen(Me.ClientRectangle)
        rc.Offset(-Me.Left, -Me.Top)
        If Me.ClientSize.Width > 0 AndAlso Me.ClientSize.Height > 0 Then
          'Paint the ClientArea
          Using backBrush As New SolidBrush(Color.FromArgb(128, SystemColors.Control))
            gr.FillRectangle(backBrush, rc)
          End Using
          'Allow for AutoScroll behaviour
          Using clientBuffer As New Bitmap(Me.DisplayRectangle.Width, Me.DisplayRectangle.Height, PixelFormat.Format32bppPArgb)
            Dim pos As Point = Me.AutoScrollPosition
            'Paint the Controls
            For Each ctl As Control In Me.Controls
              Dim rcCtl As Rectangle = ctl.Bounds
              rcCtl.Offset(-pos.X, -pos.Y)
              ctl.DrawToBitmap(clientBuffer, rcCtl)
            Next
            gr.DrawImage(clientBuffer, New Rectangle(rc.Location, Me.ClientSize), New Rectangle(New Point(-pos.X, -pos.Y), Me.ClientSize), GraphicsUnit.Pixel)
          End Using
        End If
        'Paint the NonClientArea
        gr.SetClip(rc, CombineMode.Exclude)
        gr.FillPath(Brushes.CornflowerBlue, Me.CreateFormShape())
        If Me.WindowState <> FormWindowState.Minimized Then
          Using scrollFont As New Font("Marlett", SystemInformation.VerticalScrollBarArrowHeight, FontStyle.Regular, GraphicsUnit.Pixel)
            Using sf As New StringFormat()
              sf.Alignment = StringAlignment.Center
              sf.LineAlignment = StringAlignment.Center
              'Paint any scrollbars
              If Me.HScroll Then
                Dim hScrollRect As Rectangle = Me.RectangleToScreen(New Rectangle(0, Me.ClientSize.Height, Me.ClientSize.Width, SystemInformation.HorizontalScrollBarHeight))
                hScrollRect.Offset(-Me.Left, -Me.Top)
                gr.FillRectangle(Brushes.Aqua, hScrollRect)
                Dim thumbRect As Rectangle = New Rectangle(hScrollRect.X, hScrollRect.Y, hScrollRect.Height, hScrollRect.Height)
                gr.FillRectangle(Brushes.Green, thumbRect)
                gr.DrawString("3", scrollFont, Brushes.White, thumbRect)
                Dim sbi As New NativeMethods.SCROLLBARINFO()
                sbi.cbSize = Marshal.SizeOf(sbi)
                NativeMethods.GetScrollBarInfo(Me.Handle, NativeMethods.OBJID_HSCROLL, sbi)
                thumbRect = Me.RectangleToScreen(Rectangle.FromLTRB(sbi.xyThumbTop, Me.ClientRectangle.Bottom + 1, sbi.xyThumbBottom, Me.ClientRectangle.Bottom + hScrollRect.Height + 1))
                thumbRect.Offset(-Me.Left, -Me.Top)
                gr.FillRectangle(Brushes.Red, thumbRect)
                thumbRect = New Rectangle(hScrollRect.Right - hScrollRect.Height, hScrollRect.Y, hScrollRect.Height, hScrollRect.Height)
                gr.FillRectangle(Brushes.Green, thumbRect)
                gr.DrawString("4", scrollFont, Brushes.White, thumbRect)
              End If
              If (Me.VScroll) Then
                Dim vScrollRect As Rectangle = Me.RectangleToScreen(New Rectangle(Me.ClientSize.Width, 0, SystemInformation.VerticalScrollBarWidth, Me.ClientSize.Height))
                vScrollRect.Offset(-Me.Left, -Me.Top)
                gr.FillRectangle(Brushes.Aqua, vScrollRect)
                Dim thumbRect As Rectangle = New Rectangle(vScrollRect.X, vScrollRect.Y, vScrollRect.Width, vScrollRect.Width)
                gr.FillRectangle(Brushes.Green, thumbRect)
                gr.DrawString("5", scrollFont, Brushes.White, thumbRect)
                Dim sbi As New NativeMethods.SCROLLBARINFO()
                sbi.cbSize = Marshal.SizeOf(sbi)
                NativeMethods.GetScrollBarInfo(Me.Handle, NativeMethods.OBJID_VSCROLL, sbi)
                thumbRect = Me.RectangleToScreen(Rectangle.FromLTRB(Me.ClientRectangle.Right + 1, sbi.xyThumbTop, Me.ClientRectangle.Right + vScrollRect.Width + 1, sbi.xyThumbBottom))
                thumbRect.Offset(-Me.Left, -Me.Top)
                gr.FillRectangle(Brushes.Red, thumbRect)
                thumbRect = New Rectangle(vScrollRect.X, vScrollRect.Bottom - vScrollRect.Width, vScrollRect.Width, vScrollRect.Width)
                gr.FillRectangle(Brushes.Green, thumbRect)
                gr.DrawString("6", scrollFont, Brushes.White, thumbRect)
              End If
              'Paint the Caption Buttons
              Dim buttonSize As Size = SystemInformation.SmallCaptionButtonSize
              buttonSize.Width -= 3
              Dim buttonRect As Rectangle = New Rectangle(Me.Width - buttonSize.Width - 5, 5, buttonSize.Width, buttonSize.Height)
              gr.FillEllipse(Brushes.Red, buttonRect)
              buttonRect.Offset(-buttonRect.Width - 2, 0)
              gr.FillEllipse(Brushes.Orange, buttonRect)
              buttonRect.Offset(-buttonRect.Width - 2, 0)
              gr.FillEllipse(Brushes.Yellow, buttonRect)
              'Paint the Caption String
              sf.Alignment = StringAlignment.Near
              sf.Trimming = StringTrimming.EllipsisCharacter
              gr.DrawString(Me.Text, SystemFonts.CaptionFont, Brushes.White, RectangleF.FromLTRB(3, buttonRect.Top, buttonRect.Left, buttonRect.Bottom), sf)
            End Using
          End Using
          gr.ResetClip()
        End If
      End Using
      'Use Interop to transfer the bitmap to the screen.
      Dim screenDC As IntPtr = NativeMethods.GetDC(IntPtr.Zero)
      Dim memDC As IntPtr = NativeMethods.CreateCompatibleDC(screenDC)
      Dim hBitmap As IntPtr = backBuffer.GetHbitmap(Color.FromArgb(0))
      Dim oldBitmap As IntPtr = NativeMethods.SelectObject(memDC, hBitmap)
      Dim blend As New NativeMethods.BLENDFUNCTION(255)
      Dim ptDst As Point = Me.Location
      Dim szDst As Size = backBuffer.Size
      Dim ptSrc As Point = Point.Empty
      NativeMethods.UpdateLayeredWindow(Me.Handle, screenDC, ptDst, szDst, memDC, ptSrc, 0, blend, NativeMethods.ULW_ALPHA)
      NativeMethods.SelectObject(memDC, oldBitmap)
      NativeMethods.DeleteObject(hBitmap)
      NativeMethods.DeleteDC(memDC)
      NativeMethods.DeleteDC(screenDC)
    End Using
  End Sub
  Private Function CreateFormShape() As GraphicsPath
    Dim formShape As GraphicsPath = New GraphicsPath()
    formShape.AddArc(0, 0, 12, 12, 180, 90)
    formShape.AddArc(Me.Width - 13, 0, 12, 12, 270, 90)
    formShape.AddLine(Me.Width - 1, 12, Me.Width - 1, Me.Height - 1)
    formShape.AddLine(Me.Width - 1, Me.Height - 1, 0, Me.Height - 1)
    formShape.CloseFigure()
    Return formShape
  End Function
End Class
Public Class NativeMethods
  <DllImport("user32.dll", SetLastError:=True)> _
  Friend Shared Function UpdateLayeredWindow(ByVal hwnd As IntPtr, ByVal hdcDst As IntPtr, ByRef pptDst As Point, ByRef psize As Size, ByVal hdcSrc As IntPtr, ByRef pptSrc As Point, ByVal crKey As Int32, ByRef pblend As BLENDFUNCTION, ByVal dwFlags As Int32) As Boolean
  End Function

  <DllImport("uxtheme.dll")> _
  Friend Shared Function SetWindowTheme(ByVal hwnd As IntPtr, ByVal pszSubAppName As String, ByVal pszSubIdList As String) As IntPtr
  End Function
  <DllImport("user32.dll", SetLastError:=True)> _
  Friend Shared Function GetDC(ByVal hWnd As IntPtr) As IntPtr
  End Function
  <DllImport("gdi32.dll")> _
  Friend Shared Function CreateCompatibleDC(ByVal dc As IntPtr) As IntPtr
  End Function
  <DllImport("gdi32.dll")> _
  Friend Shared Function SelectObject(ByVal hdc As IntPtr, ByVal hObj As IntPtr) As IntPtr
  End Function
  <DllImport("gdi32.dll")> _
  Friend Shared Function DeleteDC(ByVal dc As IntPtr) As IntPtr
  End Function
  <DllImport("gdi32.dll")> _
  Friend Shared Function DeleteObject(ByVal hObj As IntPtr) As IntPtr
  End Function
  <DllImport("user32.dll", SetLastError:=True)> _
  Friend Shared Function GetScrollBarInfo(ByVal hwnd As IntPtr, ByVal idObject As Int32, ByRef psbi As SCROLLBARINFO) As Boolean
  End Function
  <StructLayout(LayoutKind.Sequential, Pack:=1)> _
  Friend Structure BLENDFUNCTION
    Public BlendOp, BlendFlags, SourceConstantAlpha, AlphaFormat As Byte
    Public Sub New(ByVal alpha As Byte)
      Me.BlendOp = AC_SRC_OVER
      Me.BlendFlags = 0
      Me.SourceConstantAlpha = alpha
      Me.AlphaFormat = AC_SRC_ALPHA
    End Sub
  End Structure
  <StructLayout(LayoutKind.Sequential)> _
  Friend Structure SCROLLBARINFO
    Public cbSize As Int32
    Public rcScrollBar As RECT
    Public dxyLineButton, xyThumbTop, xyThumbBottom, reserved As Int32
    Public scrollbar, incbtn, pgup, thumb, pgdn, decbtn As Int32
  End Structure

  <StructLayout(LayoutKind.Sequential)> _
  Friend Structure RECT
    Public Left, Top, Right, Bottom As Int32
  End Structure
  Friend Const AC_SRC_OVER As Int32 = &H0
  Friend Const AC_SRC_ALPHA As Int32 = &H1
  Friend Const ULW_ALPHA As Int32 = &H2
  Friend Const WS_EX_LAYERED As Int32 = &H80000
  Friend Const OBJID_HSCROLL As Int32 = &HFFFFFFFA '-6
  Friend Const OBJID_VSCROLL As Int32 = &HFFFFFFFB '-5
End Class


This Program uses a Layered Window so that all drawing is done by you, including that of child controls. This type of window will never recieve or respond to a standard Paint message.

Advantages of this method include the ability to draw the Scrollbars in any style you wish as well as having the ability to change Alpha levels on a pixel by pixel basis. Just be aware that if you set alpha to zero, then the mouse events will fall through to the window below.

A disadvantage to this method is that not all child windows support DrawToBitmap() and so will not render themselves correctly with the simple UpdateWindow() method used here.

You will need to expand the code to paint the window differently depending upon window focus and mouse position, but adding non client mouse handling is beyond the scope of this simple example. You may call UpdateWindow() whenever the Form or one of it's child controls needs repainting.

DOWNLOAD PROJECT VB NET HERE!


by: Klampok_Child | Original Source Code by: http://dotnetrix.co.uk