Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Const MERGECOPY = &HC000CA
'将图变暗,如同待关机一般
Private Sub Command1_Click()
Dim hBitmap As Long, hBrush As Long
Dim hdcscr As Long
Dim widthscr As Long
Dim heightscr As Long
Dim bybits(1 To 16) As Byte
'创建花色对象
bybits(1) = &H55: bybits(3) = &HAA: bybits(5) = &H55: bybits(7) = &HAA
bybits(9) = &H55: bybits(11) = &HAA: bybits(13) = &H55: bybits(15) = &HAA
hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1))
hBrush = CreatePatternBrush(hBitmap)
'得到屏幕句柄
hdcscr = GetDC(0)
'得到屏幕的高与宽,单位为象素
widthscr = Screen.Width \ Screen.TwipsPerPixelX
heightscr = Screen.Height \ Screen.TwipsPerPixelY
'选用对象
hOldPatten = SelectObject(hdcscr, hBrush)
'产生屏幕变暗效果
BitBlt hdcscr, 0, 0, widthscr, heightscr, hdcscr, 0, 0, MERGECOPY
'恢复屏幕的对象
SelectObject hdcscr, hOldPatten
ReleaseDC 0, hdcscr
'删除位图与花色对象
DeleteObject hBrush
DeleteObject hBitmap
End Sub
'回复原本的画面
Private Sub Command2_Click()
InvalidateRect 0, 0, 1
End Sub