Fading A Bitmap

[clarkkent]

Thủ thuật: Fading A Bitmap
Tác giả: Sưu tầm
Mô tả: Fading A Bitmap

---

để test bạn thêm vào 1 PictureBox (Chọn 1 hình cho Picture), 1 Command, copy code sau vào rồi F5

Mã: Chọn hết

1. 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
2. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
3. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
4. Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
5. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
6. Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
7. Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
8.  
9. Private Const SRCAND = &H8800C6
10. Private Const SRCCOPY = &HCC0020
11.  
12. Private Sub Command1_Click()
13.     Dim lDC As Long
14.     Dim lBMP As Long
15.     Dim W As Integer
16.     Dim H As Integer
17.     Dim lColor As Long
18.    
19.     Screen.MousePointer = vbHourglass
20.    
21.     W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
22.     H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
23.     '
24.     ' Create Memory Compatible Bitmap to that in Picture1
25.     '
26.     lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
27.     '
28.     ' Create Compatible DC in memory
29.     '
30.     lDC = CreateCompatibleDC(Picture1.hdc)
31.     '
32.     ' Select the Bitmap into the memory DC
33.     '
34.     Call SelectObject(lDC, lBMP)
35.     BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
36.     '
37.     ' Quickly clear the Picture in Picture1
38.     '
39.     Picture1 = LoadPicture("")
40.    
41.     For lColor = 255 To 0 Step -3
42.         '
43.         ' Set the backcolor to a gray scale -> black
44.         '
45.         Picture1.BackColor = RGB(lColor, lColor, lColor)
46.         '
47.         ' Copy the bitmap into the picturebox 'AND' with the backcolor
48.         '
49.         BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
50.         '
51.         ' Pause for a bit
52.         '
53.         Sleep 15
54.     Next
55.     '
56.     ' Clear up our DC's and Bitmaps
57.     '
58.     Call DeleteDC(lDC)
59.     Call DeleteObject(lBMP)
60.     Screen.MousePointer = vbDefault
61.    
62. End Sub
63.