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
Code: Select all
- 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
- Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
- Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
- Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
- Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
- Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
-
- Private Const SRCAND = &H8800C6
- Private Const SRCCOPY = &HCC0020
-
- Private Sub Command1_Click()
- Dim lDC As Long
- Dim lBMP As Long
- Dim W As Integer
- Dim H As Integer
- Dim lColor As Long
-
- Screen.MousePointer = vbHourglass
-
- W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
- H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
- '
- ' Create Memory Compatible Bitmap to that in Picture1
- '
- lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
- '
- ' Create Compatible DC in memory
- '
- lDC = CreateCompatibleDC(Picture1.hdc)
- '
- ' Select the Bitmap into the memory DC
- '
- Call SelectObject(lDC, lBMP)
- BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
- '
- ' Quickly clear the Picture in Picture1
- '
- Picture1 = LoadPicture("")
-
- For lColor = 255 To 0 Step -3
- '
- ' Set the backcolor to a gray scale -> black
- '
- Picture1.BackColor = RGB(lColor, lColor, lColor)
- '
- ' Copy the bitmap into the picturebox 'AND' with the backcolor
- '
- BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
- '
- ' Pause for a bit
- '
- Sleep 15
- Next
- '
- ' Clear up our DC's and Bitmaps
- '
- Call DeleteDC(lDC)
- Call DeleteObject(lBMP)
- Screen.MousePointer = vbDefault
-
- End Sub
-