DWM API 的使用已经更新,请见:http://hi.baidu.com/micstudio/blog/item/29ec4cef245164ca2e2e21d3.html
比如:
'很好的代码,粘贴到窗体内即可使用
'缺点:直接使用 GDI+,导致 GDI 绘制的图像及文本出现不正常;在没有使用另外的某 DWM API 时(忘了……),窗口边框与客户区间还会有边界。
'Vista Home Premium 以下(不含)的系统不支持,请勿使用
'此源代码为从网上某处搜索得来,感谢原作者!
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):
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 均可),这才是最终的解决方案。
相关声明嘛……啊我放在另一个模块里面了,比较乱,不复制了,网上都有。