Vista Aero 效果的纯 DWM API 实现，以及发光字 etc

DWM API 的使用已经更新，请见：http://hi.baidu.com/micstudio/blog/item/29ec4cef245164ca2e2e21d3.html
比如：



'很好的代码，粘贴到窗体内即可使用

'缺点：直接使用 GDI+，导致 GDI 绘制的图像及文本出现不正常；在没有使用另外的某 DWM API 时（忘了……），窗口边框与客户区间还会有边界。

'Vista Home Premium 以下（不含）的系统不支持，请勿使用

 

'此源代码为从网上某处搜索得来，感谢原作者！

 

 

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75

Option Explicit       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 Type MARGINS    m_Left As Long   m_Right As Long   m_Top As Long   m_Bottom As Long End Type       Private Declare Function DwmEnableBlurBehindWindow Lib "dwmapi" (ByVal hWnd As Long, pBlurBehind As DWM_BLURBEHIND) As Long Private Declare Function DwmEnableComposition Lib "dwmapi" (ByVal bEnabled As Long) As Long      Private Const DWM_BB_ENABLE = &H1&  Private Const DWM_BB_BLURREGION = &H2&  Private Const DWM_BB_TRANSITIONONMAXIMIZED = &H4       Private Type DWM_BLURBEHIND      dwFlags As Long     fEnable As Long     hRgnBlur As Long     fTransitionOnMaximized As Long End Type       Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long      Private Const LWA_COLORKEY = &H1  Private Const WS_EX_LAYERED = &H80000  Private Const GWL_EXSTYLE = (-20)       Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong 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 Type RECT          Left As Long         Top As Long         Right As Long         Bottom As Long End Type       Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long      Private Sub Form_Load()  Dim m_transparencyKey  As Long m_transparencyKey = 0  SetWindowLong Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED  SetLayeredWindowAttributesByColor Me.hWnd, &HC8C9CA, 0, LWA_COLORKEY  Dim mg As MARGINS, en As Long mg.m_Left = -1  mg.m_Bottom = -1  mg.m_Right = -1  mg.m_Top = -1  Dim R&, t&, bb As DWM_BLURBEHIND  bb.dwFlags = DWM_BB_ENABLE Or DWM_BB_BLURREGION  bb.fEnable = 1  bb.hRgnBlur = 0  bb.fTransitionOnMaximized = 1  DwmEnableBlurBehindWindow hWnd, bb  End Sub      Private Sub Form_Paint()  Dim hBrush As Long, m_Rect As RECT, hBrushOld As Long hBrush = CreateSolidBrush(&HC8C9CA)  hBrushOld = SelectObject(Me.hdc, hBrush)  GetClientRect Me.hWnd, m_Rect  FillRect Me.hdc, m_Rect, hBrush  SelectObject Me.hdc, hBrushOld  DeleteObject hBrush  End Sub

如果上面的代码在 VB .NET 中直接用 AllowTransparency 和 TransparencyKey 实现，则会得到完美玻璃化（无边框）的效果。

 

+新内容

以及自己根据资料写的一个函数，绘制发光文本（使用 VB .NET）：

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46

Public Function DrawGlowingText(ByVal hDC As IntPtr, ByVal Text As String, ByVal Font As Font, ByVal Color As Color, ByVal Rect As Rectangle, ByVal GlowSize As Integer) As Integer     Dim hTheme As Integer = OpenThemeData(GetDesktopWindow, "TextStyle")      If hTheme > 0 Then         Dim dib As New BITMAPINFO          Dim dto As New DTTOPTS          Dim hMemDC As Integer = CreateCompatibleDC(hDC)              With dib.bmiHeader              .biSize = 40              .biWidth = Rect.Width * 40              .biHeight = -Rect.Height * Font.Size              .biPlanes = 1              .biBitCount = 32              .biCompression = BI_RGB          End With             With dto              .dwSize = Len(dto)              .dwFlags = DTT_GLOWSIZE Or DTT_COMPOSITED Or DTT_TEXTCOLOR              .iGlowSize = GlowSize                  .crText = ARGB2RGB(Color)    '注意，.NET 中以 ARGB 方式保存颜色信息，而 Windows Theme API 以 RGB 方式解读信息          End With             Font = New Font(Font.FontFamily.Name, Font.Size)              Dim hDIB As Integer = CreateDIBSection(hDC, dib, DIB_RGB_COLORS, 0, 0, 0)          Dim hObjectOld As Integer = SelectObject(hMemDC, hDIB)          SelectObject(hMemDC, Font.ToHfont())              Rect.X = Rect.X + GlowSize              DrawThemeTextEx(hTheme, hMemDC, 0, 0, Text, -1, 0, Rect, dto)          BitBlt(hDC, Rect.Top, Rect.Left, Rect.Width, Rect.Height, hMemDC, 0, 0, SRCCOPY)              SelectObject(hMemDC, hObjectOld)          'SetTextColor(hMemDC, intOldTextColor)          DeleteObject(hDIB)          DeleteDC(hMemDC)              CloseThemeData(hTheme)          Return 0      Else         Return GetLastError()      End If End Function

附：最好是使用相应 WM_PAINT 消息时将窗体整个用黑色画刷填充，然后再向上面绘制图片、文字（DrawThemeTextEx 或者 GraphicsPath 均可），这才是最终的解决方案。

 

相关声明嘛……啊我放在另一个模块里面了，比较乱，不复制了，网上都有。