VB6.0调用dwmapi.dll实现窗体Aero化

这是开启Aero时的效果:

这是没有开启Aero时的效果

源码如下:

模块内容:

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
Public Type MARGINS    m_Left As Long    m_Right As Long    m_Top As Long    m_Button As LongEnd Type
Public Type RECT    Left As Long    Top As Long    Right As Long    Bottom As LongEnd Type
Public Const LWA_COLORKEY = &H1Public Const GWL_EXSTYLE = (-20)Public Const WS_EX_LAYERED = &H80000
Dim Inied As BooleanPublic Declare Function DwmExtendFrameIntoClientArea Lib “dwmapi.dll” (ByVal Hwnd As Long, margin As MARGINS) As LongPublic Declare Function DwmIsCompositionEnabled Lib “dwmapi.dll” (ByRef enabledptr As Boolean) As LongPublic Declare Function CreateSolidBrush Lib “gdi32” (ByVal crColor As Long) As LongPublic Declare Function FillRect Lib “user32” (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPublic Declare Function SelectObject Lib “gdi32” (ByVal hdc As Long, ByVal hObject As Long) As LongPublic Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As LongPublic Declare Function GetClientRect Lib “user32” (ByVal Hwnd As Long, lpRect As RECT) As LongPublic Declare Function SetLayeredWindowAttributesByColor Lib “user32” Alias “SetLayeredWindowAttributes” (ByVal Hwnd As Long, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPublic Declare Function SetWindowLong Lib “user32” Alias “SetWindowLongA” (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Declare Function GetWindowLong Lib “user32” Alias “GetWindowLongA” (ByVal Hwnd As Long, ByVal nIndex As Long) As Long

Form内容:

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

大家看到了那个lable在字体放大的时候会出现锯齿，所以推荐使用GDI来抗锯齿。