VB实现全窗体的磨砂玻璃效果

Tesla.Angela · 发表于 2011-4-8 18:31:22

很多年前从网上抄来的，但是最近才看到效果（当年的旧电脑没法启动Aero特效）。

把一下代码复制到类模块中：

Option Explicit
Private Type MARGINS
m_Left As Long
m_Right As Long
m_Top As Long
m_Button As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function DwmIsCompositionEnabled Lib "dwmapi.dll" (ByRef enabledptr As Long) As Long
Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi.dll" (ByVal hwnd As Long, margin As MARGINS) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SetLayeredWindowAttributesByColor Lib "user32" Alias "SetLayeredWindowAttributes" (ByVal hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessageA Lib "user32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_EX_LAYERED As Long = &H80000
Private Const LWA_COLORKEY As Long = &H1
Private m_transparencyKey As Long
Public Sub OnFormLoad(ByVal WindowHandle As Long)
m_transparencyKey = RGB(255, 255, 1)
SetWindowLong WindowHandle, GWL_EXSTYLE, GetWindowLong(WindowHandle, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributesByColor WindowHandle, m_transparencyKey, 0, LWA_COLORKEY
Dim mg As MARGINS, en As Long
mg.m_Left = -1
mg.m_Button = -1
mg.m_Right = -1
mg.m_Top = -1
DwmIsCompositionEnabled en
If en Then
DwmExtendFrameIntoClientArea WindowHandle, mg
End If
End Sub
Public Sub OnFormPaint(ByVal whdc As Long, ByVal wndh As Long)
Dim hBrush As Long, m_Rect As RECT, hBrushOld As Long
hBrush = CreateSolidBrush(m_transparencyKey)
hBrushOld = SelectObject(whdc, hBrush)
GetClientRect wndh, m_Rect
FillRect whdc, m_Rect, hBrush
SelectObject whdc, hBrushOld
DeleteObject hBrush
End Sub
Public Sub OnMouseDown(ByVal wndh As Long)
ReleaseCapture
SendMessageA wndh, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

复制代码

再把以下代码复制到窗体中：

Option Explicit
Dim ggs As New Cls_GroundGlassStyle
Private Sub Form_Load()
ggs.OnFormLoad Me.hwnd
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
ggs.OnMouseDown Me.hwnd
End Sub
Private Sub Form_Paint()
ggs.OnFormPaint Me.hdc, Me.hwnd
End Sub