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 均可），这才是最终的解决方案。

 

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