This short bit of code shows how to fade a picture inside a PictureBox using a few simple WinAPI methods.
The code works by creating a memory compatible DC and Bitmap to that of the picture within the PictureBox. The PictureBox is then cleared and has it’s background set to various shades of gray (eventually black) – the bitmap is then ‘blitted’ to the PictureBox and each pixel is ‘AND’ed with the background colour to achieve the fade effect.
'
' Form1 with a PictureBox (picture1) and a command button (command1)
'
'
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
'
