论坛广场 › Visual Basic › VB实现全窗体的磨砂玻璃效果

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

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

很多年前从网上抄来的，但是最近才看到效果（当年的旧电脑没法启动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

效果如下：

LittlePig 发表于 2011-4-8 22:44:42

好大的英特尔logo……:L

马大哈 发表于 2011-4-18 14:20:17

哈哈,果然好大....:lol

Xor 发表于 2011-4-18 21:22:34

啊，幸好我老电脑不算太差，让我几年前就体验到了各种aero特效。不过你的方法代码也太多了吧！其中很多代码都可以安全删去，比如
    mg.m_Left = -1
    mg.m_Button = -1
    mg.m_Right = -1
    mg.m_Top = -1只保留一个就行。

opboy45 发表于 2011-5-1 16:31:53

回复 Tesla.Angela 的帖子

迫不及待测试了~

opboy45 发表于 2011-5-1 16:34:15

回复 Tesla.Angela 的帖子

貌似缺少DLL哦~？

Tesla.Angela 发表于 2011-5-1 19:08:20

回复 opboy45 的帖子

仅仅支持vista/win7。

zhouhui222 发表于 2012-4-23 11:07:02

学习学习，gdi？

查看完整版本: VB实现全窗体的磨砂玻璃效果