Visual Basic 实现窗口磨砂玻璃样式

〆红瞳朱雀丶痛

       用VB制作磨砂玻璃效果，在Win7和Vista系统下经常会看到这种效果，现在我就用VB来实现。

首先要在 Visual Basic 6.0  中新建一个工程，一个标准程序和一个标准模块。

模块代码如下：

Public Type MARGINS    m_Left As Long
    m_Right As Long
    m_Top As Long
    m_Button As Long
End Type
Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Public Const LWA_COLORKEY = &H1
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
    Dim Inied As Boolean
Public Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi.dll" (ByVal hwnd As Long, margin As MARGINS) As Long
'[DllImport("dwmapi.dll", PreserveSig=false)]
Public Declare Function DwmIsCompositionEnabled Lib "dwmapi.dll" (ByRef enabledptr As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public 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
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Form窗体代码如下：

Dim m_transparencyKey As Long
Private Sub Form_Load()
    m_transparencyKey = RGB(255, 255, 1)
    SetWindowLong Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetLayeredWindowAttributesByColor Me.hwnd, 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 Me.hwnd, mg
    End If
    Exit Sub
End Sub
Private Sub Form_Paint()
Dim hBrush As Long, m_Rect As RECT, hBrushOld As Long
    hBrush = CreateSolidBrush(m_transparencyKey)
    hBrushOld = SelectObject(Me.hdc, hBrush)
    GetClientRect Me.hwnd, m_Rect
    FillRect Me.hdc, m_Rect, hBrush
    SelectObject Me.hdc, hBrushOld
    DeleteObject hBrush
End Sub

效果图：










好了，代码就是这50多行。在某些显卡不支持，视频卡驱动程序与 Windows 显示驱动程序模型(WDDM)兼容，则此视频卡可以支持 Aero

by：HackAny

〆红瞳朱雀丶痛

沙发自己坐，各位朋友如果有更好的意见的话，请给我留言，谢谢。

caxzan

楼主，图片不行了，还有就是会不会卡死

〆红瞳朱雀丶痛

caxzan 发表于 2014-8-8 17:27
楼主，图片不行了，还有就是会不会卡死

图片看不到吗？