Private Declare Function AlphaBlend Lib "msimg32" (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 widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean
Dim lTime As Integer, Flag As Integer
Sub ShowTransparency(cSrc As PictureBox, cDest As PictureBox, ByVal nLevel As Byte)
cDest.Cls
With cSrc
AlphaBlend cDest.hDC, 0, 0, .ScaleWidth, .ScaleHeight, .hDC, 0, 0, .ScaleWidth, .ScaleHeight, nLevel * &H10000
End With
cDest.Refresh
End Sub
Private Sub Command1_Click()
Flag = 1
If lTime < 255 Then Timer1.Enabled = True
End Sub
Private Sub Command2_Click()
Flag = -1
If lTime > 0 Then Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
lTime = lTime + Flag * 5
If lTime > 255 Or lTime < 0 Then
Timer1.Enabled = False
Exit Sub
End If
ShowTransparency P1, P2, lTime
End Sub
Dim aDC As Long ' Device context of the MDIClient area
Dim rcClient As RECT ' RECT structure with dimension of MDIClient area
Dim aPic As StdPicture ' Logo picture for center of MDIClient area
Dim aMask As StdPicture ' Mask image so we can draw the logo transparent
Dim picDC As Long ' temporary DC to hold the picture image in
Dim maskDC As Long ' temporary DC to hold the mask image in
Dim oldBmp1 As Long ' original 1x1 bitmap for the temporary picDC
Dim oldBmp2 As Long ' original 1x1 bitmap for the temporary maskDC
Dim backDC As Long ' back buffer device context.
Dim backBmp As Long ' back buffer bitmap
Dim aBmp As BITMAP ' bitmap used to get the picture's dimensions
Dim abrush As Long ' Brush used to paint the background of the MDIClient area
Dim x As Long ' X location for drawing our logo picture
Dim Y As Long ' Y location for drawing our logo picture
' Get the MDIClient area's device context
aDC = GetDC(hwnd)
' Get the MDIClient dimensions
GetWindowRect hwnd, rcClient
' shift the origin to 0,0
rcClient.right = rcClient.right - rcClient.left
rcClient.bottom = rcClient.bottom - rcClient.top
rcClient.top = 0
rcClient.left = 0
' Create a backbuffer so we can draw in memory first, then transfer the
' background to the MDIClient area all at once.
backDC = CreateCompatibleDC(aDC)
backBmp = CreateCompatibleBitmap(aDC, rcClient.right, rcClient.bottom)
DeleteObject SelectObject(backDC, backBmp)
'Paint window background
If chkBGTexture.Value = 0 Then
' Use the system setting for application workspace
abrush = CreateSolidBrush(GetSysColor(12))
Else
' Create a pattern brush using the background texture
abrush = CreatePatternBrush(imgBG.Picture.Handle)
End If
' Fill the backbuffer with the selected brush
FillRect backDC, rcClient, abrush
' Clean up our brush object
DeleteObject abrush
' Do logo, if that has been selected.
If chkLogo.Value = 1 Then
Set aPic = imgLogo.Picture
Set aMask = imgLogoMask.Picture
' Get logo's dimensions - overkill? Probably, but I HATE screwing around
' with himetric units. They make me want to kick something really really
' hard. And you wouldn't want me to break my toe, would you? :-p
GetObject aPic.Handle, Len(aBmp), aBmp
' Create some compatible device contexts to hold our logo pics in
picDC = CreateCompatibleDC(aDC)
maskDC = CreateCompatibleDC(aDC)
' Select our pictures into the temporary DCs, and keep a reference to
' the original 1x1 bitmaps so we can replace them later, freeing our logo images.
oldBmp1 = SelectObject(picDC, aPic.Handle)
oldBmp2 = SelectObject(maskDC, aMask.Handle)
' Calculate the x and y location for our logo
x = (rcClient.right - aBmp.bmWidth) \ 2
Y = (rcClient.bottom - aBmp.bmHeight) \ 2
' punch the hole for our logo
BitBlt backDC, x, Y, aBmp.bmWidth, aBmp.bmHeight, maskDC, 0, 0, vbMergePaint
' draw the logo
BitBlt backDC, x, Y, aBmp.bmWidth, aBmp.bmHeight, picDC, 0, 0, vbSrcAnd
' Replace the original 1x1 bitmaps (which frees our logo pictures)
SelectObject picDC, oldBmp1
SelectObject maskDC, oldBmp2
' Clean up the graphics objects
DeleteDC picDC
DeleteObject oldBmp1
DeleteDC maskDC
DeleteObject oldBmp2
End If
' blt from backbuffer into client rectangle - Transfers the entire thing at once.
BitBlt aDC, 0, 0, rcClient.right, rcClient.bottom, backDC, 0, 0, vbSrcCopy
' Clean up our backbuffer objects
DeleteDC backDC
DeleteObject backBmp
' Release our hold on the device context
ReleaseDC hwnd, aDC