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

效果图：





By：HackAny

〆红瞳朱雀丶痛

wzj005 发表于 2014-8-8 18:47
已经点赞了，希望楼主多发点VB的教程

VB的话我会比较多发表吧，因为不会其他编程语言了。

〆红瞳朱雀丶痛

opelwang 发表于 2015-4-21 08:25
我在win7下，怎么没有效果？

Win7下没有效果，你看看电脑有没有打开Aero或有没有支持Aero

丶阡陌丨殇

支持！！！！沙发！

〆红瞳朱雀丶痛

丶阡陌丨殇 发表于 2014-8-8 18:03
支持！！！！沙发！

多谢支持哈。

ytw6176

非常喜欢~~  感谢分享  收藏了

Mr丶晓东

路过帮顶下~~~~~~~~~~~·

ww1113330

感谢分享，收藏了，以后方便使用

myqqq

我有透明的源码

wzj005

已经点赞了，希望楼主多发点VB的教程

〆红瞳朱雀丶痛

myqqq 发表于 2014-8-8 18:45
我有透明的源码

透明代码比较少。