WEBINAR: On-demand webcast
How to Boost Database Development Productivity on Linux, Docker, and Kubernetes with Microsoft SQL Server 2017 REGISTER >
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 '