利用VB产生屏幕变暗的效果.1、在Form1中加入两个CommandButton和一个PictureBox. 2、在Form1的代码窗口中添加以下代码: Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End TypePrivate 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 PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight 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 LongPrivate bybits(1 To 16) As Byte Private hBitmap As Long, hBrush As Long Private hDesktopWnd As LongPrivate Sub Command1_Click() Dim rop As Long, res As Long Dim hdc5 As Long, width5 As Long, height5 As Longhdc5 = GetDC(0) width5 = Screen.Width \ Screen.TwipsPerPixelX height5 = Screen.Height \ Screen.TwipsPerPixelYrop = &HA000C9 Call SelectObject(hdc5, hBrush) res = PatBlt(hdc5, 0, 0, width5, height5, rop) Call DeleteObject(hBrush)res = ReleaseDC(0, hdc5) End SubPrivate Sub Command2_Click() Dim aa As Long aa = InvalidateRect(0, 0, 1) End SubPrivate Sub Form_Load() Dim ary Dim i As Long ary = Array(&H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0) For i = 1 To 16 bybits(i) = ary(i - 1) Next i hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1)) hBrush = CreatePatternBrush(hBitmap) Picture1.ForeColor = RGB(0, 0, 0) Picture1.BackColor = RGB(255, 255, 255) Picture1.ScaleMode = 3 End Sub 运行程序,按Command1就可以使屏幕暗下来,按Command2恢复。
Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End TypePrivate 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 PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight 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 LongPrivate bybits(1 To 16) As Byte Private hBitmap As Long, hBrush As Long Private hDesktopWnd As Long '将图变暗,如同待关机一般 Private Sub Command1_Click() Dim rop As Long, res As Long Dim hdc5 As Long, width5 As Long, height5 As Long '如果只要让Picture1有效果将底下三行unMark取代 hdc5, width5, height5三个值 'hdc5 = Picture1.hdc 'width5 = Picture1.ScaleWidth 'height5 = Picture1.ScaleHeight'底下三行设定整个萤幕都暗下来 hdc5 = GetDC(0) width5 = Screen.Width \ Screen.TwipsPerPixelX height5 = Screen.Height \ Screen.TwipsPerPixelYrop = &HA000C9 '与原图做and运算 Call SelectObject(hdc5, hBrush) res = PatBlt(hdc5, 0, 0, width5, height5, rop) Call DeleteObject(hBrush) '如果只暗picture1则底下这一行要起来 res = ReleaseDC(0, hdc5) End Sub '回复原本的画面 Private Sub Command2_Click() Dim aa As Long '如果只暗picture1则底下这一行要unMark起来 'Picture1.Refresh'如果只暗picture1则底下这一行要起来 aa = InvalidateRect(0, 0, 1) End SubPrivate Sub Form_Load() Dim ary Dim i As Long ary = Array(&H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0, _ &H55, &H0, &HAA, &H0) For i = 1 To 16 bybits(i) = ary(i - 1) Next i hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1)) hBrush = CreatePatternBrush(hBitmap) Picture1.ForeColor = RGB(0, 0, 0) Picture1.BackColor = RGB(255, 255, 255) Picture1.ScaleMode = 3 End Sub
2、在Form1的代码窗口中添加以下代码:
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End TypePrivate 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 PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As
Long, ByVal nWidth As Long, ByVal nHeight 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 LongPrivate bybits(1 To 16) As Byte
Private hBitmap As Long, hBrush As Long
Private hDesktopWnd As LongPrivate Sub Command1_Click()
Dim rop As Long, res As Long
Dim hdc5 As Long, width5 As Long, height5 As Longhdc5 = GetDC(0)
width5 = Screen.Width \ Screen.TwipsPerPixelX
height5 = Screen.Height \ Screen.TwipsPerPixelYrop = &HA000C9
Call SelectObject(hdc5, hBrush)
res = PatBlt(hdc5, 0, 0, width5, height5, rop)
Call DeleteObject(hBrush)res = ReleaseDC(0, hdc5)
End SubPrivate Sub Command2_Click()
Dim aa As Long
aa = InvalidateRect(0, 0, 1)
End SubPrivate Sub Form_Load()
Dim ary
Dim i As Long
ary = Array(&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0)
For i = 1 To 16
bybits(i) = ary(i - 1)
Next i
hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1))
hBrush = CreatePatternBrush(hBitmap)
Picture1.ForeColor = RGB(0, 0, 0)
Picture1.BackColor = RGB(255, 255, 255)
Picture1.ScaleMode = 3
End Sub
运行程序,按Command1就可以使屏幕暗下来,按Command2恢复。
Left As Long
Top As Long
Right As Long
Bottom As Long
End TypePrivate 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 PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight 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 LongPrivate bybits(1 To 16) As Byte
Private hBitmap As Long, hBrush As Long
Private hDesktopWnd As Long
'将图变暗,如同待关机一般
Private Sub Command1_Click()
Dim rop As Long, res As Long
Dim hdc5 As Long, width5 As Long, height5 As Long
'如果只要让Picture1有效果将底下三行unMark取代 hdc5, width5, height5三个值
'hdc5 = Picture1.hdc
'width5 = Picture1.ScaleWidth
'height5 = Picture1.ScaleHeight'底下三行设定整个萤幕都暗下来
hdc5 = GetDC(0)
width5 = Screen.Width \ Screen.TwipsPerPixelX
height5 = Screen.Height \ Screen.TwipsPerPixelYrop = &HA000C9 '与原图做and运算
Call SelectObject(hdc5, hBrush)
res = PatBlt(hdc5, 0, 0, width5, height5, rop)
Call DeleteObject(hBrush)
'如果只暗picture1则底下这一行要起来
res = ReleaseDC(0, hdc5)
End Sub
'回复原本的画面
Private Sub Command2_Click()
Dim aa As Long
'如果只暗picture1则底下这一行要unMark起来
'Picture1.Refresh'如果只暗picture1则底下这一行要起来
aa = InvalidateRect(0, 0, 1)
End SubPrivate Sub Form_Load()
Dim ary
Dim i As Long
ary = Array(&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0, _
&H55, &H0, &HAA, &H0)
For i = 1 To 16
bybits(i) = ary(i - 1)
Next i
hBitmap = CreateBitmap(8, 8, 1, 1, bybits(1))
hBrush = CreatePatternBrush(hBitmap)
Picture1.ForeColor = RGB(0, 0, 0)
Picture1.BackColor = RGB(255, 255, 255)
Picture1.ScaleMode = 3
End Sub