代码:
核心函数:UpdateLayeredWindow
问题点:windows api调用结构体需自定义
Imports System.Runtime.InteropServices
Imports System.Drawing.Drawing2D
Public Class ShadowForm
Inherits Form
Public isRoundShadow As Boolean = True
Public isShowShadow As Boolean = True
Private WithEvents _MainForm As Form
Private _ShadowWidth As Integer = 9
Private _ShadowImage As Bitmap
Public Property ShadowWidth As Integer
Get
Return _ShadowWidth
End Get
Set(value As Integer)
Me._ShadowWidth = value
ReSet()
End Set
End Property
Protected Overrides ReadOnly Property CreateParams As CreateParams
Get
Dim x As CreateParams = MyBase.CreateParams
x.ExStyle = x.ExStyle Or &H80000
Return x
End Get
End Property
Public Shared Function RegisterShadowForm(form As Form) As ShadowForm
Return New ShadowForm(form)
End Function
Private Sub New(form As Form)
' 此调用是设计器所必需的。
'InitializeComponent()
Me.FormBorderStyle = Windows.Forms.FormBorderStyle.None
' 在 InitializeComponent() 调用之后添加任何初始化。
_MainForm = form
InitMe()
End Sub
Private Sub InitMe()
_MainForm.Owner = Me
Me.ShowInTaskbar = False
End Sub
Public Sub SizeChange() Handles _MainForm.SizeChanged
ReSet()
End Sub
Public Sub LocationChange() Handles _MainForm.LocationChanged
Me.Location = New Point(_MainForm.Location.X - Me._ShadowWidth, _MainForm.Location.Y - Me._ShadowWidth)
End Sub
Private Sub ShowMe(sender As Object, e As EventArgs) Handles _MainForm.Shown
Me.Show()
ReSet()
End Sub
Private Sub ReSet()
If Me.isShowShadow Then
SetSizeLocation()
SetShadowImage()
setPaint()
End If
End Sub
Private Sub SetSizeLocation()
Me.Size = New Size(_MainForm.Size.Width + 2 * Me._ShadowWidth, _MainForm.Size.Height + 2 * Me._ShadowWidth)
Me.Location = New Point(_MainForm.Location.X - Me._ShadowWidth, _MainForm.Location.Y - Me._ShadowWidth)
End Sub
Private Function SetShadowImage() As Bitmap
If IsNothing(_ShadowImage) Then
_ShadowImage = New Bitmap(System.Windows.Forms.Screen.PrimaryScreen.Bounds.Width, System.Windows.Forms.Screen.PrimaryScreen.Bounds.Height)
End If
Graphics.FromImage(_ShadowImage).Clear(Color.Transparent)
If isRoundShadow Then
_ShadowImage = SetRoundShadowStyle()
Else
_ShadowImage = SetShadowStyle()
End If
Return _ShadowImage
End Function
Private Function SetRoundShadowStyle()
'_ShadowImage = New Bitmap(Me.Width, Me.Height)
Dim g As Graphics = Graphics.FromImage(_ShadowImage)
g.SmoothingMode = SmoothingMode.HighQuality
Dim pen As Pen = New Pen(Color.FromArgb(0), 2)
For i As Integer = 0 To _ShadowWidth Step 1
pen.Color = Color.FromArgb((255 / 10 / _ShadowWidth) * i, 0, 0, 0)
g.DrawPath(pen, CreateRoundPath(New Rectangle(i, i, Me.Width - 2 * i - 1, Me.Height - 2 * i - 1)))
Next
Return _ShadowImage
End Function
Private Function CreateRoundPath(rect As Rectangle)
Dim cornerRadius As Integer = ShadowWidth * 0.6
Dim roundedRect As GraphicsPath = New GraphicsPath()
roundedRect.AddArc(rect.X, rect.Y, cornerRadius * 2, cornerRadius * 2, 180, 90)
roundedRect.AddLine(rect.X + cornerRadius, rect.Y, rect.Right - cornerRadius * 2, rect.Y)
roundedRect.AddArc(rect.X + rect.Width - cornerRadius * 2, rect.Y, cornerRadius * 2, cornerRadius * 2, 270, 90)
roundedRect.AddLine(rect.Right, rect.Y + cornerRadius * 2, rect.Right, rect.Y + rect.Height - cornerRadius * 2)
roundedRect.AddArc(rect.X + rect.Width - cornerRadius * 2, rect.Y + rect.Height - cornerRadius * 2, cornerRadius * 2, cornerRadius * 2, 0, 90)
roundedRect.AddLine(rect.Right - cornerRadius * 2, rect.Bottom, rect.X + cornerRadius * 2, rect.Bottom)
roundedRect.AddArc(rect.X, rect.Bottom - cornerRadius * 2, cornerRadius * 2, cornerRadius * 2, 90, 90)
roundedRect.AddLine(rect.X, rect.Bottom - cornerRadius * 2, rect.X, rect.Y + cornerRadius * 2)
roundedRect.CloseFigure()
Return roundedRect
End Function
Protected Overridable Function SetShadowStyle()
'_ShadowImage = New Bitmap(Me.Width, Me.Height)
Dim g As Graphics = Graphics.FromImage(_ShadowImage)
Dim pen As Pen = New Pen(Color.FromArgb(0), 2)
For i As Integer = 0 To _ShadowWidth Step 1
pen.Color = Color.FromArgb((255 / 10 / _ShadowWidth) * i, 0, 0, 0)
g.DrawRectangle(pen, New Rectangle(i, i, Me.Width - 2 * i - 1, Me.Height - 2 * i - 1))
Next
Return _ShadowImage
End Function
Private Sub setPaint()
Dim zero As IntPtr = IntPtr.Zero
Dim dc As IntPtr = GetDC(IntPtr.Zero)
Dim hgdiobj As IntPtr = IntPtr.Zero
Dim hdc As IntPtr = CreateCompatibleDC(dc)
Try
Dim pptdst As WinPoint = New WinPoint
pptdst.x = Me.Left
pptdst.y = Me.Top
Dim psize As WinSize = New WinSize With {.cx = Me.Width, .cy = Me.Height}
Dim pblend As BLENDFUNCTION = New BLENDFUNCTION()
Dim pprsrc As WinPoint = New WinPoint With {.x = 0, .y = 0}
hgdiobj = _ShadowImage.GetHbitmap(Color.FromArgb(0))
zero = SelectObject(hdc, hgdiobj)
pblend.BlendOp = 0
pblend.SourceConstantAlpha = Byte.Parse("255")
pblend.AlphaFormat = 1
pblend.BlendFlags = 0
If Not UpdateLayeredWindow(MyBase.Handle, dc, pptdst, psize, hdc, pprsrc, 0, pblend, 2) Then
Dim x = GetLastError()
End If
Return
Finally
If hgdiobj <> IntPtr.Zero Then
SelectObject(hdc, zero)
DeleteObject(hgdiobj)
End If
ReleaseDC(IntPtr.Zero, dc)
DeleteDC(hdc)
End Try
End Sub
#Region "import dll"
<DllImport("gdi32.dll")>
Private Shared Function DeleteDC(hdc As IntPtr) As Boolean
End Function
<DllImport("user32.dll")>
Private Shared Function ReleaseDC(hwnd As IntPtr, hdc As IntPtr) As Integer
End Function
<DllImport("kernel32.dll")>
Private Shared Function GetLastError() As Integer
End Function
<DllImport("user32.dll")>
Private Shared Function UpdateLayeredWindow(hwnd As IntPtr, sdc As IntPtr, ByRef loc As WinPoint, ByRef size As WinSize, srcdc As IntPtr, ByRef sloc As WinPoint, c As Integer, ByRef bd As BLENDFUNCTION, x As Integer) As Integer
End Function
<DllImport("gdi32.dll")>
Private Shared Function CreateCompatibleDC(intptr As IntPtr) As IntPtr
End Function
<DllImport("user32.dll")>
Private Shared Function GetDC(hwnd As IntPtr) As IntPtr
End Function
<DllImport("gdi32.dll")>
Private Shared Function DeleteObject(hwnd As IntPtr) As Boolean
End Function
<DllImport("gdi32.dll")>
Private Shared Function SelectObject(hwnd As IntPtr, obj As IntPtr) As Integer
End Function
#End Region
#Region "WinStructure"
Structure WinPoint
Dim x As Integer
Dim y As Integer
End Structure
Structure WinSize
Dim cx As Integer
Dim cy As Integer
End Structure
Structure BLENDFUNCTION
Dim BlendOp As Byte
Dim BlendFlags As Byte
Dim SourceConstantAlpha As Byte
Dim AlphaFormat As Byte
End Structure
#End Region
End Class