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 均可),这才是最终的解决方案。
相关声明嘛……啊我放在另一个模块里面了,比较乱,不复制了,网上都有。