none
VB6 实现Windows 7/Vista 的Aero效果 RRS feed

  • 常规讨论

  • 启动Visual Basic 6.0

    新建一个窗体。然后插入以下代码。

    Option Explicit
    
    Dim m_transparencyKey As Long
    Dim isAero As Boolean
    Dim mg As MARGINS
    
    Private Sub Form_Load()
    DwmIsCompositionEnabled isAero
    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
    
     On Error GoTo ern
     mg.m_Left = -1
     mg.m_Button = -1
     mg.m_Right = -1
     mg.m_Top = -1
    
     DwmExtendFrameIntoClientArea Me.Hwnd, mg
    
     Exit Sub
    
    ern:
     MsgBox Err.Description
     End Sub
    
     Private Sub Form_Paint()
     If isAero Then
     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 If
     End Sub

    新建一个标准模块。插入以下代码:

    Option Explicit
    
    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
     Public Declare Function DwmIsCompositionEnabled Lib "dwmapi.dll" (ByRef enabledptr As Boolean) 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
    然后运行即可看到Aero效果

    2016年3月20日 7:53